These are the sources Tezos imported to Coq by the current development version of coq-of-ocaml. Tezos is a crypto-currency with smart-contracts and an upgradable protocol. The market cap of Tezos is more than US $500 millions at the time of writting. Write at web [at] clarus [dot] me for more information. Work currently made at Nomadic Labs.
src/bin_attacker/attacker_main.ml 2 errors
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let () = Attacker_minimal.main ()
src/bin_attacker/attacker_main.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/bin_attacker/attacker_minimal.ml 142 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Format
include Logging.Make (struct
let name = "attacker"
end)
module Proto = Client_embedded_proto_alpha
(* the genesis block and network *)
let genesis_block_hashed =
Block_hash.of_b58check "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"
let network = Store.Net genesis_block_hashed
let network = Store.Chain_id.Id genesis_block_hashed
(* the bootstrap accounts and actions like signing to do with them *)
let source_account = List.nth Proto.Bootstrap_storage.accounts 4
let destination_account = List.nth Proto.Bootstrap_storage.accounts 0
let wrong_account = List.nth Proto.Bootstrap_storage.accounts 1
let another_account = List.nth Proto.Bootstrap_storage.accounts 2
let signed = Ed25519.append_signature source_account.secret_key
let signed_wrong = Ed25519.append_signature wrong_account.secret_key
(* forge a block from a list of operations *)
let block_forged ?prev ops =
let from_int64 x =
[ Bytes.of_string Proto.Constants_repr.version_number;
Proto.Fitness_repr.int64_to_bytes x ]
in
let pred = match prev with None -> genesis_block_hashed | Some x -> x in
let block ops =
Store.Block_header.
{
chain_id = network;
predecessor = pred;
timestamp = Systime_os.now ();
fitness = from_int64 1L;
operations = ops;
}
in
let open Proto in
let generate_proof_of_work_nonce () =
Rand.generate Proto.Alpha_context.Constants.proof_of_work_nonce_size
in
let generate_seed_nonce () =
match
Proto.Nonce_storage.of_bytes
@@ Rand.generate Proto.Alpha_context.Constants.nonce_length
with
| Error _ ->
assert false
| Ok nonce ->
nonce
in
Block_repr.forge_header
(block ops)
Block_repr.
{
baking_slot = {level = Raw_level_repr.of_int32_exn 1l; priority = 0l};
seed_nonce_hash = Proto.Nonce_storage.hash (generate_seed_nonce ());
proof_of_work_nonce = generate_proof_of_work_nonce ();
}
(* forge a transaction *)
let tx_forged ?dest amount fee =
let open Proto.Operation_repr in
let open Proto.Tez_repr in
let open Proto.Contract_repr in
let trgt =
match dest with None -> destination_account | Some dest -> dest
in
let src = source_account in
let tx =
Transaction
{
amount = of_cents_exn amount;
parameters = None;
destination = default_contract trgt.public_key_hash;
}
in
let op =
Sourced_operations
(Manager_operations
{
source = default_contract src.public_key_hash;
public_key = Some src.public_key;
fee = of_cents_exn fee;
counter = 1l;
operations = [tx];
})
in
forge {chain_id = network} op
(* forge a list of proposals, california eat your heart out *)
let props_forged period props =
let open Proto.Operation_repr in
let src = source_account in
let props = Proposals {period; proposals = props} in
let op =
Sourced_operations
(Delegate_operations {source = src.public_key; operations = [props]})
in
forge {chain_id = network} op
(* "forge" a ballot *)
let ballot_forged period prop vote =
let open Proto.Operation_repr in
let src = source_account in
let ballot = Ballot {period; proposal = prop; ballot = vote} in
let op =
Sourced_operations
(Delegate_operations {source = src.public_key; operations = [ballot]})
in
forge {chain_id = network} op
let identity = P2p_identity.generate Crypto_box.default_target
(* connect to the network, run an action and then disconnect *)
let try_action addr port action =
let socket = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
Lwt_unix.connect socket (Lwt_unix.ADDR_INET (uaddr, port))
>>= fun () ->
let io_sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 14) () in
let conn = P2p_io_scheduler.register io_sched socket in
P2p_connection.authenticate
~proof_of_work_target:Crypto_box.default_target
~incoming:false
conn
(addr, port)
identity
Distributed_db.Raw.supported_versions
>>=? fun (_, auth_fd) ->
P2p_connection.accept auth_fd Distributed_db.Raw.encoding
>>= function
| Error _ ->
failwith "Connection rejected by peer."
| Ok conn ->
action conn
>>=? fun () -> P2p_connection.close conn >>= fun () -> return_unit
let replicate n x =
let rec replicate_acc acc n x =
if n <= 0 then acc else replicate_acc (x :: acc) (n - 1) x
in
replicate_acc [] n x
let send conn (msg : Distributed_db.Message.t) =
P2p_connection.write conn (P2p.Raw.Message msg)
let request_block_times block_hash n conn =
let open Block_hash in
lwt_log_notice "requesting %a block %d times" pp_short block_hash n
>>= fun () ->
let block_hashes = replicate n block_hash in
send conn (Get_block_headers (network, block_hashes))
let request_op_times op_signed n conn =
let open Operation_hash in
let op_hash = hash_bytes [op_signed] in
lwt_log_notice "sending %a transaction" pp_short op_hash
>>= fun () ->
send conn (Operation op_signed)
>>=? fun () ->
lwt_log_notice "requesting %a transaction %d times" pp_short op_hash n
>>= fun () ->
let op_hashes = replicate n op_hash in
send conn (Get_operations op_hashes)
let send_block_size n conn =
let bytes = Bytes.create n in
let open Block_hash in
lwt_log_notice
"propagating fake %d byte block %a"
n
pp_short
(hash_bytes [bytes])
>>= fun () -> send conn (Block bytes)
let send_protocol_size n conn =
let bytes = Bytes.create n in
let open Protocol_hash in
lwt_log_notice
"propagating fake %d byte protocol %a"
n
pp_short
(hash_bytes [bytes])
>>= fun () -> send conn (Protocol bytes)
let send_operation_size n conn =
let op_faked = Bytes.create n in
let op_hashed = Operation_hash.hash_bytes [op_faked] in
lwt_log_notice
"propagating fake %d byte operation %a"
n
Operation_hash.pp_short
op_hashed
>>= fun () ->
send conn (Operation op_faked)
>>=? fun () ->
let block = signed (block_forged [op_hashed]) in
let block_hashed = Block_hash.hash_bytes [block] in
lwt_log_notice
"propagating block %a with operation"
Block_hash.pp_short
block_hashed
>>= fun () -> send conn (Block block)
let send_operation_bad_signature () conn =
let open Operation_hash in
let signed_wrong_op = signed_wrong (tx_forged 5L 1L) in
let hashed_wrong_op = hash_bytes [signed_wrong_op] in
lwt_log_notice
"propagating operation %a with wrong signature"
pp_short
hashed_wrong_op
>>= fun () ->
send conn (Operation signed_wrong_op)
>>=? fun () ->
let block = signed (block_forged [hashed_wrong_op]) in
let block_hashed = Block_hash.hash_bytes [block] in
lwt_log_notice
"propagating block %a with operation"
Block_hash.pp_short
block_hashed
>>= fun () -> send conn (Block block)
let send_block_bad_signature () conn =
let open Block_hash in
let signed_wrong_block = signed_wrong (block_forged []) in
lwt_log_notice
"propagating block %a with wrong signature"
pp_short
(hash_bytes [signed_wrong_block])
>>= fun () -> send conn (Block signed_wrong_block)
let double_spend () conn =
let spend account =
let op_signed = signed (tx_forged ~dest:account 199999999L 1L) in
let op_hashed = Operation_hash.hash_bytes [op_signed] in
let block_signed = signed (block_forged [op_hashed]) in
let block_hashed = Block_hash.hash_bytes [block_signed] in
lwt_log_notice "propagating operation %a" Operation_hash.pp_short op_hashed
>>= fun () ->
send conn (Operation op_signed)
>>=? fun () ->
lwt_log_notice "propagating block %a" Block_hash.pp_short block_hashed
>>= fun () -> send conn (Block block_signed)
in
spend destination_account >>=? fun () -> spend another_account
let long_chain n conn =
lwt_log_notice "propogating %d blocks" n
>>= fun () ->
let prev_ref = ref genesis_block_hashed in
let rec loop k =
if k < 1 then return_unit
else
let block = signed (block_forged ~prev:!prev_ref []) in
prev_ref := Block_hash.hash_bytes [block] ;
send conn (Block block) >>=? fun () -> loop (k - 1)
in
loop n
let lots_transactions amount fee n conn =
let signed_op = signed (tx_forged amount fee) in
let rec loop k =
if k < 1 then return_unit
else send conn (Operation signed_op) >>=? fun () -> loop (k - 1)
in
let ops = replicate n (Operation_hash.hash_bytes [signed_op]) in
let signed_block = signed (block_forged ops) in
lwt_log_notice "propogating %d transactions" n
>>= fun () ->
loop n
>>=? fun () ->
lwt_log_notice
"propagating block %a with wrong signature"
Block_hash.pp_short
(Block_hash.hash_bytes [signed_block])
>>= fun () -> send conn (Block signed_block)
let main () =
let addr = Ipaddr.V6.localhost in
let port = 9732 in
let run_action action = try_action addr port action in
let run_cmd_unit lwt =
Arg.Unit
(fun () ->
Lwt_main.run
( lwt ()
>>= function
| Ok () ->
Lwt.return_unit
| Error err ->
lwt_log_error "Error: %a" pp_print_error err
>>= fun () -> Lwt.return_unit ))
in
let run_cmd_int_suffix lwt =
Arg.String
(fun str ->
let last = str.[String.length str - 1] in
let init = String.sub str 0 (String.length str - 1) in
let n =
if last == 'k' || last == 'K' then int_of_string init * (1 lsl 10)
else if last == 'm' || last == 'M' then
int_of_string init * (1 lsl 20)
else if last == 'g' || last == 'G' then
int_of_string init * (1 lsl 30)
else int_of_string str
in
Lwt_main.run
( lwt n
>>= function
| Ok () ->
Lwt.return_unit
| Error err ->
lwt_log_error "Error: %a" pp_print_error err
>>= fun () -> Lwt.return_unit ))
in
let cmds =
[ ( "-1",
run_cmd_int_suffix
(run_action << request_block_times genesis_block_hashed),
"[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}blocks."
);
( "-2",
run_cmd_int_suffix
(run_action << request_op_times (signed (tx_forged 5L 1L))),
"[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}ops."
);
( "-3",
run_cmd_int_suffix (run_action << send_block_size),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
block." );
( "-4",
run_cmd_int_suffix (run_action << send_operation_size),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
operation." );
( "-5",
run_cmd_int_suffix (run_action << send_protocol_size),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
protocol." );
( "-6",
run_cmd_unit (run_action << send_operation_bad_signature),
"Attempt to propagate a transaction with a bad signature." );
( "-7",
run_cmd_unit (run_action << send_block_bad_signature),
"Attempt to propagate a block with a bad signature." );
( "-8",
run_cmd_unit (run_action << double_spend),
"Attempt to send the same transaction in two blocks" );
( "-9",
run_cmd_int_suffix (run_action << long_chain),
"[N {,K,M,G}] Attempt to send a chain of N {,kilo,mega,giga}blocks" );
( "-10",
run_cmd_int_suffix (run_action << lots_transactions 0L 0L),
"[N {,K,M,G}] Attempt to send N {,kilo,mega,giga}ops" ) ]
in
Arg.parse cmds print_endline "Tezos Evil Client"
src/bin_attacker/attacker_minimal.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Format.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition genesis_block_hashed {A : Type} : A :=
op_startypeminuserrorstar
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.
Definition network {A : Type} : A := op_startypeminuserrorstar.
Definition network {A : Type} : A := op_startypeminuserrorstar.
Definition source_account {A : Type} : A :=
Stdlib.List.nth op_startypeminuserrorstar 4.
Definition destination_account {A : Type} : A :=
Stdlib.List.nth op_startypeminuserrorstar 0.
Definition wrong_account {A : Type} : A :=
Stdlib.List.nth op_startypeminuserrorstar 1.
Definition another_account {A : Type} : A :=
Stdlib.List.nth op_startypeminuserrorstar 2.
Definition signed {A : Type} : A :=
op_startypeminuserrorstar (secret_key source_account).
Definition signed_wrong {A : Type} : A :=
op_startypeminuserrorstar (secret_key wrong_account).
Definition block_forged {A B C : Type} (prev : option A) (ops : B) : C :=
let from_int64 {D : Type} (x : D) : list string :=
cons (Stdlib.Bytes.of_string op_startypeminuserrorstar)
(cons (op_startypeminuserrorstar x) []) in
let pred :=
match prev with
| None => genesis_block_hashed
| Some x => x
end in
let block {D E : Type} (ops : D) : E :=
op_startypeminuserrorstar in
let generate_proof_of_work_nonce {D : Type} (function_parameter : unit) : D :=
let 'tt := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar in
let generate_seed_nonce {D : Type} (function_parameter : unit) : D :=
let 'tt := function_parameter in
match
apply op_startypeminuserrorstar
(op_startypeminuserrorstar op_startypeminuserrorstar) with
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok nonce => nonce
end in
op_startypeminuserrorstar (block ops) op_startypeminuserrorstar.
Definition tx_forged {A B C D : Type} (dest : option A) (amount : B) (fee : C)
: D := op_startypeminuserrorstar.
Definition props_forged {A B C : Type} (period : A) (props : B) : C :=
op_startypeminuserrorstar.
Definition ballot_forged {A B C D : Type} (period : A) (prop : B) (vote : C)
: D := op_startypeminuserrorstar.
Definition identity {A : Type} : A :=
op_startypeminuserrorstar op_startypeminuserrorstar.
Definition try_action {A B C D E : Type} (addr : A) (port : B) (action : C -> D)
: E :=
let socket :=
op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar 0 in
let uaddr := op_startypeminuserrorstar addr in
op_startypeminuserrorstar
(op_startypeminuserrorstar socket op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let io_sched := op_startypeminuserrorstar (Z.shiftl 1 14) tt in
let conn := op_startypeminuserrorstar io_sched socket in
op_startypeminuserrorstar
(op_startypeminuserrorstar op_startypeminuserrorstar false conn
(addr, port) identity op_startypeminuserrorstar)
(fun function_parameter =>
let '(_, auth_fd) := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar auth_fd op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
OCaml.Stdlib.failwith "Connection rejected by peer." % string
| Stdlib.Ok conn =>
op_startypeminuserrorstar (action conn)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar conn)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar))
end))).
Definition replicate {A : Type} (n : Z) (x : A) : list A :=
let fix replicate_acc {B : Type} (acc : list B) (n : Z) (x : B) : list B :=
if OCaml.Stdlib.le n 0 then
acc
else
replicate_acc (cons x acc) (Z.sub n 1) x in
replicate_acc [] n x.
Definition send {A B C : Type} (conn : A) (function_parameter : B) : C :=
let '_ := function_parameter in
op_startypeminuserrorstar conn op_startypeminuserrorstar.
Definition request_block_times {A B C D : Type}
(block_hash : A) (n : B) (conn : C) : D := op_startypeminuserrorstar.
Definition request_op_times {A B C D : Type} (op_signed : A) (n : B) (conn : C)
: D := op_startypeminuserrorstar.
Definition send_block_size {A B : Type} (n : Z) (conn : A) : B :=
let bytes := Stdlib.Bytes.create n in
op_startypeminuserrorstar.
Definition send_protocol_size {A B : Type} (n : Z) (conn : A) : B :=
let bytes := Stdlib.Bytes.create n in
op_startypeminuserrorstar.
Definition send_operation_size {A B : Type} (n : Z) (conn : A) : B :=
let op_faked := Stdlib.Bytes.create n in
let op_hashed := op_startypeminuserrorstar (cons op_faked []) in
op_startypeminuserrorstar
(op_startypeminuserrorstar "propagating fake %d byte operation %a" % string
n op_startypeminuserrorstar op_hashed)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let block := signed (block_forged None (cons op_hashed [])) in
let block_hashed := op_startypeminuserrorstar (cons block []) in
op_startypeminuserrorstar
(op_startypeminuserrorstar
"propagating block %a with operation" % string
op_startypeminuserrorstar block_hashed)
(fun function_parameter =>
let 'tt := function_parameter in
send conn op_startypeminuserrorstar))).
Definition send_operation_bad_signature {A B : Type} (function_parameter : unit)
: A -> B :=
let 'tt := function_parameter in
fun conn => op_startypeminuserrorstar.
Definition send_block_bad_signature {A B : Type} (function_parameter : unit)
: A -> B :=
let 'tt := function_parameter in
fun conn => op_startypeminuserrorstar.
Definition double_spend {A B : Type} (function_parameter : unit) : A -> B :=
let 'tt := function_parameter in
fun conn =>
let spend {C D : Type} (account : C) : D :=
let op_signed :=
signed
(tx_forged (Some account)
(* ❌ Constant of type int64 is converted to int *)
199999999
(* ❌ Constant of type int64 is converted to int *)
1) in
let op_hashed := op_startypeminuserrorstar (cons op_signed []) in
let block_signed := signed (block_forged None (cons op_hashed [])) in
let block_hashed := op_startypeminuserrorstar (cons block_signed []) in
op_startypeminuserrorstar
(op_startypeminuserrorstar "propagating operation %a" % string
op_startypeminuserrorstar op_hashed)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar "propagating block %a" % string
op_startypeminuserrorstar block_hashed)
(fun function_parameter =>
let 'tt := function_parameter in
send conn op_startypeminuserrorstar))) in
op_startypeminuserrorstar (spend destination_account)
(fun function_parameter =>
let 'tt := function_parameter in
spend another_account).
Definition long_chain {A B : Type} (n : Z) (conn : A) : B :=
op_startypeminuserrorstar
(op_startypeminuserrorstar "propogating %d blocks" % string n)
(fun function_parameter =>
let 'tt := function_parameter in
let prev_ref := Stdlib.ref genesis_block_hashed in
let fix loop {C : Type} (k : Z) : C :=
if OCaml.Stdlib.lt k 1 then
op_startypeminuserrorstar
else
let block :=
signed (block_forged (Some (Stdlib.op_exclamation prev_ref)) []) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq prev_ref
(op_startypeminuserrorstar (cons block [])) in
op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
loop (Z.sub k 1)) in
loop n).
Definition lots_transactions {A B C D : Type}
(amount : A) (fee : B) (n : Z) (conn : C) : D :=
let signed_op := signed (tx_forged None amount fee) in
let fix loop {E : Type} (k : Z) : E :=
if OCaml.Stdlib.lt k 1 then
op_startypeminuserrorstar
else
op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
loop (Z.sub k 1)) in
let ops := replicate n (op_startypeminuserrorstar (cons signed_op [])) in
let signed_block := signed (block_forged None ops) in
op_startypeminuserrorstar
(op_startypeminuserrorstar "propogating %d transactions" % string n)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (loop n)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
"propagating block %a with wrong signature" % string
op_startypeminuserrorstar
(op_startypeminuserrorstar (cons signed_block [])))
(fun function_parameter =>
let 'tt := function_parameter in
send conn op_startypeminuserrorstar))).
Definition main (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let addr := op_startypeminuserrorstar in
let port := 9732 in
let run_action {A B C : Type} (action : A -> B) : C :=
try_action addr port action in
let run_cmd_unit {A : Type} (lwt : unit -> A) : Stdlib.Arg.spec :=
Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar (lwt tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => op_startypeminuserrorstar
| Stdlib.Error err =>
op_startypeminuserrorstar
(op_startypeminuserrorstar "Error: %a" % string
op_startypeminuserrorstar err)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar)
end))) in
let run_cmd_int_suffix {A : Type} (lwt : Z -> A) : Stdlib.Arg.spec :=
Stdlib.Arg.String
(fun str =>
let last := Stdlib.String.get str (Z.sub (OCaml.String.length str) 1) in
let init := Stdlib.String.sub str 0 (Z.sub (OCaml.String.length str) 1)
in
let n :=
if
orb (Stdlib.op_eqeq last "k" % char)
(Stdlib.op_eqeq last "K" % char) then
Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 10)
else
if
orb (Stdlib.op_eqeq last "m" % char)
(Stdlib.op_eqeq last "M" % char) then
Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 20)
else
if
orb (Stdlib.op_eqeq last "g" % char)
(Stdlib.op_eqeq last "G" % char) then
Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 30)
else
OCaml.Stdlib.int_of_string str in
op_startypeminuserrorstar
(op_startypeminuserrorstar (lwt n)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => op_startypeminuserrorstar
| Stdlib.Error err =>
op_startypeminuserrorstar
(op_startypeminuserrorstar "Error: %a" % string
op_startypeminuserrorstar err)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar)
end))) in
let cmds :=
cons
("-1" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action
(request_block_times genesis_block_hashed))),
"[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}blocks."
% string)
(cons
("-2" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action
(request_op_times
(signed
(tx_forged None
(* ❌ Constant of type int64 is converted to int *)
5
(* ❌ Constant of type int64 is converted to int *)
1))))),
"[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}ops."
% string)
(cons
("-3" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action send_block_size)),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake block."
% string)
(cons
("-4" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action send_operation_size)),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake operation."
% string)
(cons
("-5" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action send_protocol_size)),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake protocol."
% string)
(cons
("-6" % string,
(run_cmd_unit
(op_startypeminuserrorstar run_action
send_operation_bad_signature)),
"Attempt to propagate a transaction with a bad signature." %
string)
(cons
("-7" % string,
(run_cmd_unit
(op_startypeminuserrorstar run_action
send_block_bad_signature)),
"Attempt to propagate a block with a bad signature." %
string)
(cons
("-8" % string,
(run_cmd_unit
(op_startypeminuserrorstar run_action double_spend)),
"Attempt to send the same transaction in two blocks" %
string)
(cons
("-9" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action long_chain)),
"[N {,K,M,G}] Attempt to send a chain of N {,kilo,mega,giga}blocks"
% string)
(cons
("-10" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action
(lots_transactions
(* ❌ Constant of type int64 is converted to int *)
0
(* ❌ Constant of type int64 is converted to int *)
0))),
"[N {,K,M,G}] Attempt to send N {,kilo,mega,giga}ops"
% string) []))))))))) in
Arg.parse cmds OCaml.Stdlib.print_endline "Tezos Evil Client" % string.
src/bin_client/client_protocols_commands.ml 43 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let group =
{Clic.name = "protocols"; title = "Commands for managing protocols"}
let proto_param ~name ~desc t =
Clic.param
~name
~desc
(Clic.parameter (fun _ str -> Lwt.return (Protocol_hash.of_b58check str)))
t
let commands () =
let open Clic in
let check_dir _ dn =
if Sys.is_directory dn then return dn
else failwith "%s is not a directory" dn
in
let check_dir_parameter = parameter check_dir in
[ command
~group
~desc:"List protocols known by the node."
no_options
(prefixes ["list"; "protocols"] stop)
(fun () (cctxt : #Client_context.full) ->
Shell_services.Protocol.list cctxt
>>=? fun protos ->
Lwt_list.iter_s
(fun ph -> cctxt#message "%a" Protocol_hash.pp ph)
protos
>>= fun () -> return_unit);
command
~group
~desc:"Inject a new protocol into the node."
no_options
( prefixes ["inject"; "protocol"]
@@ param
~name:"dir"
~desc:"directory containing the sources of a protocol"
check_dir_parameter
@@ stop )
(fun () dirname (cctxt : #Client_context.full) ->
Lwt.catch
(fun () ->
Tezos_base_unix.Protocol_files.read_dir dirname
>>=? fun (_hash, proto) ->
Shell_services.Injection.protocol cctxt proto
>>= function
| Ok hash ->
cctxt#message
"Injected protocol %a successfully"
Protocol_hash.pp
hash
>>= fun () -> return_unit
| Error err ->
cctxt#error
"Error while injecting protocol from %s: %a"
dirname
Error_monad.pp_print_error
err
>>= fun () -> return_unit)
(fun exn ->
cctxt#error
"Error while injecting protocol from %s: %a"
dirname
Error_monad.pp_print_error
[Error_monad.Exn exn]
>>= fun () -> return_unit));
command
~group
~desc:"Dump a protocol from the node's record of protocol."
no_options
( prefixes ["dump"; "protocol"]
@@ proto_param ~name:"protocol hash" ~desc:""
@@ stop )
(fun () ph (cctxt : #Client_context.full) ->
Shell_services.Protocol.contents cctxt ph
>>=? fun proto ->
Tezos_base_unix.Protocol_files.write_dir
(Protocol_hash.to_short_b58check ph)
~hash:ph
proto
>>=? fun () ->
cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph
>>= fun () -> return_unit);
command
~group
~desc:"Fetch a protocol from the network."
no_options
( prefixes ["fetch"; "protocol"]
@@ proto_param ~name:"protocol hash" ~desc:""
@@ stop )
(fun () hash (cctxt : #Client_context.full) ->
Shell_services.Protocol.fetch cctxt hash
>>= function
| Ok () ->
cctxt#message
"Protocol %a successfully fetched."
Protocol_hash.pp_short
hash
>>= fun () -> return_unit
| Error err ->
cctxt#error
"Error while fetching protocol: %a"
Error_monad.pp_print_error
err
>>= fun () -> return_unit) ]
src/bin_client/client_protocols_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "protocols" % string;
Clic.title := "Commands for managing protocols" % string |}.
Definition proto_param {A B : Type}
(name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.Protocol_hash.t -> A) B :=
Clic.param name desc
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun str => Lwt._return (Protocol_hash.of_b58check str))) t.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
let check_dir {J : Type} (function_parameter : J)
: string -> Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let '_ := function_parameter in
fun dn =>
if Sys.is_directory dn then
_return dn
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is not a directory" % string
CamlinternalFormatBasics.End_of_format))
"%s is not a directory" % string) dn in
let check_dir_parameter := parameter None check_dir in
cons
(command (Some group) "List protocols known by the node." % string
no_options
(prefixes (cons "list" % string (cons "protocols" % string [])) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Shell_services.Protocol.list cctxt)
(fun protos =>
op_gtgteq
(Lwt_list.iter_s
(fun ph =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Protocol_hash.pp ph) protos)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group) "Inject a new protocol into the node." % string
no_options
(apply (prefixes (cons "inject" % string (cons "protocol" % string [])))
(apply
(param "dir" % string
"directory containing the sources of a protocol" % string
check_dir_parameter) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun dirname =>
fun cctxt =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_base_unix.Protocol_files.read_dir dirname)
(fun function_parameter =>
let '(_hash, proto) := function_parameter in
op_gtgteq
(Shell_services.Injection.protocol cctxt None proto)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok hash =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injected protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" successfully" % string
CamlinternalFormatBasics.End_of_format)))
"Injected protocol %a successfully" % string)
Protocol_hash.pp hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error err =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while injecting protocol from " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Error while injecting protocol from %s: %a" %
string) dirname Error_monad.pp_print_error
err)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end)))
(fun exn =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while injecting protocol from " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Error while injecting protocol from %s: %a" % string)
dirname Error_monad.pp_print_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn exn) []))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Dump a protocol from the node's record of protocol." % string
no_options
(apply (prefixes (cons "dump" % string (cons "protocol" % string [])))
(apply (proto_param "protocol hash" % string "" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun ph =>
fun cctxt =>
op_gtgteqquestion (Shell_services.Protocol.contents cctxt ph)
(fun proto =>
op_gtgteqquestion
(Tezos_base_unix.Protocol_files.write_dir
(Protocol_hash.to_short_b58check ph) (Some ph) proto)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Extracted protocol " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Extracted protocol %a" % string)
Protocol_hash.pp_short ph)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))
(cons
(command (Some group) "Fetch a protocol from the network." % string
no_options
(apply
(prefixes (cons "fetch" % string (cons "protocol" % string [])))
(apply (proto_param "protocol hash" % string "" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun hash =>
fun cctxt =>
op_gtgteq (Shell_services.Protocol.fetch cctxt hash)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" successfully fetched." % string
CamlinternalFormatBasics.End_of_format)))
"Protocol %a successfully fetched." % string)
Protocol_hash.pp_short hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error err =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while fetching protocol: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Error while fetching protocol: %a" % string)
Error_monad.pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))) []))).
src/bin_client/client_rpc_commands.ml 367 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Command line interface - Generic JSON RPC interface *)
open Lwt.Infix
open Clic
open Json_schema
(*-- Assisted, schema directed input fill in --------------------------------*)
exception Unsupported_construct
type input = {
int : int -> int -> string option -> string list -> int Lwt.t;
float : string option -> string list -> float Lwt.t;
string : string option -> string list -> string Lwt.t;
bool : string option -> string list -> bool Lwt.t;
continue : string option -> string list -> bool Lwt.t;
display : string -> unit Lwt.t;
}
(* generic JSON generation from a schema with callback for random or
interactive filling *)
let fill_in ?(show_optionals = true) input schema =
let rec element path {title; kind; _} =
match kind with
| Integer {minimum; maximum; _} ->
let minimum =
match minimum with
| None ->
min_int
| Some (m, `Inclusive) ->
int_of_float m
| Some (m, `Exclusive) ->
int_of_float m + 1
in
let maximum =
match maximum with
| None ->
max_int
| Some (m, `Inclusive) ->
int_of_float m
| Some (m, `Exclusive) ->
int_of_float m - 1
in
input.int minimum maximum title path
>>= fun i -> Lwt.return (`Float (float i))
| Number _ ->
input.float title path >>= fun f -> Lwt.return (`Float f)
| Boolean ->
input.bool title path >>= fun f -> Lwt.return (`Bool f)
| String _ ->
input.string title path >>= fun f -> Lwt.return (`String f)
| Combine ((One_of | Any_of), elts) ->
let nb = List.length elts in
input.int 0 (nb - 1) (Some "Select the schema to follow") path
>>= fun n -> element path (List.nth elts n)
| Combine ((All_of | Not), _) ->
Lwt.fail Unsupported_construct
| Def_ref name ->
Lwt.return (`String (Json_query.json_pointer_of_path name))
| Id_ref _ | Ext_ref _ ->
Lwt.fail Unsupported_construct
| Array (elts, _) ->
let rec fill_loop acc n ls =
match ls with
| [] ->
Lwt.return acc
| elt :: elts ->
element (string_of_int n :: path) elt
>>= fun json -> fill_loop (json :: acc) (succ n) elts
in
fill_loop [] 0 elts >>= fun acc -> Lwt.return (`A (List.rev acc))
| Object {properties; _} ->
let properties =
if show_optionals then properties
else List.filter (fun (_, _, b, _) -> b) properties
in
let rec fill_loop acc ls =
match ls with
| [] ->
Lwt.return acc
| (n, elt, _, _) :: elts ->
element (n :: path) elt
>>= fun json -> fill_loop ((n, json) :: acc) elts
in
fill_loop [] properties >>= fun acc -> Lwt.return (`O (List.rev acc))
| Monomorphic_array (elt, specs) ->
let rec fill_loop acc min n max =
if n > max then Lwt.return acc
else
element (string_of_int n :: path) elt
>>= fun json ->
(if n < min then Lwt.return_true else input.continue title path)
>>= function
| true ->
fill_loop (json :: acc) min (succ n) max
| false ->
Lwt.return (json :: acc)
in
let max = match specs.max_items with None -> max_int | Some m -> m in
fill_loop [] specs.min_items 0 max
>>= fun acc -> Lwt.return (`A (List.rev acc))
| Any ->
Lwt.fail Unsupported_construct
| Dummy ->
Lwt.fail Unsupported_construct
| Null ->
Lwt.return `Null
in
element [] (Json_schema.root schema)
let random_fill_in ?(show_optionals = true) schema =
let display _ = Lwt.return_unit in
let int min max _ _ =
let max = Int64.of_int max and min = Int64.of_int min in
let range = Int64.sub max min in
let random_int64 = Int64.add (Random.int64 range) min in
Lwt.return (Int64.to_int random_int64)
in
let string _title _ = Lwt.return "" in
let float _ _ = Lwt.return (Random.float infinity) in
let bool _ _ = Lwt.return (Random.int 2 = 0) in
let continue _ _ = Lwt.return (Random.int 4 = 0) in
Lwt.catch
(fun () ->
fill_in
~show_optionals
{int; float; string; bool; display; continue}
schema
>>= fun json -> Lwt.return_ok json)
(fun e ->
let msg =
Printf.sprintf "Fill-in failed %s\n%!" (Printexc.to_string e)
in
Lwt.return_error msg)
let editor_fill_in ?(show_optionals = true) schema =
let tmp = Filename.temp_file "tezos_rpc_call_" ".json" in
let rec init () =
(* write a temp file with instructions *)
random_fill_in ~show_optionals schema
>>= function
| Error msg ->
Lwt.return_error msg
| Ok json ->
Lwt_io.(
with_file ~mode:Output tmp (fun fp ->
write_line fp (Data_encoding.Json.to_string json)))
>>= fun () -> edit ()
and edit () =
(* launch the user's editor on it *)
let editor_cmd =
let ed =
match (Sys.getenv_opt "EDITOR", Sys.getenv_opt "VISUAL") with
| (Some ed, _) ->
ed
| (None, Some ed) ->
ed
| (None, None) when Sys.win32 ->
(* TODO: I have no idea what I'm doing here *)
"notepad.exe"
| _ ->
(* TODO: vi on MacOSX ? *)
"nano"
in
Lwt_process.shell (ed ^ " " ^ tmp)
in
(Lwt_process.open_process_none editor_cmd)#status
>>= function
| Unix.WEXITED 0 ->
reread () >>= fun json -> delete () >>= fun () -> Lwt.return json
| Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x ->
let msg = Printf.sprintf "FAILED %d \n%!" x in
delete () >>= fun () -> Lwt.return_error msg
and reread () =
(* finally reread the file *)
Lwt_io.(with_file ~mode:Input tmp (fun fp -> read fp))
>>= fun text ->
match Data_encoding.Json.from_string text with
| Ok r ->
Lwt.return_ok r
| Error msg ->
Lwt.return_error (Format.asprintf "bad input: %s" msg)
and delete () =
(* and delete the temp file *)
Lwt_unix.unlink tmp
in
init ()
(*-- Nice list display ------------------------------------------------------*)
let rec count =
let open RPC_description in
function
| Empty ->
0
| Dynamic _ ->
1
| Static {services; subdirs} ->
let service = RPC_service.MethMap.cardinal services in
let subdirs =
match subdirs with
| None ->
0
| Some (Suffixes subdirs) ->
Resto.StringMap.fold (fun _ t r -> r + count t) subdirs 0
| Some (Arg (_, subdir)) ->
count subdir
in
service + subdirs
(*-- Commands ---------------------------------------------------------------*)
let list url (cctxt : #Client_context.full) =
let args = String.split '/' url in
RPC_description.describe cctxt ~recurse:true args
>>=? fun tree ->
let open RPC_description in
let collected_args = ref [] in
let collect arg =
if not (arg.RPC_arg.descr <> None && List.mem arg !collected_args) then
collected_args := arg :: !collected_args
in
let display_paragraph ppf description =
Format.fprintf
ppf
"@, @[%a@]"
(fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words)
(String.split ' ' description)
in
let display_arg ppf arg =
match arg.RPC_arg.descr with
| None ->
Format.fprintf ppf "%s" arg.RPC_arg.name
| Some descr ->
Format.fprintf ppf "<%s>%a" arg.RPC_arg.name display_paragraph descr
in
let display_service ppf (_path, tpath, service) =
Format.fprintf
ppf
"- %s /%s"
(RPC_service.string_of_meth service.meth)
(String.concat "/" tpath) ;
match service.description with
| None | Some "" ->
()
| Some description ->
display_paragraph ppf description
in
let display_services ppf (_path, tpath, services) =
Format.pp_print_list
(fun ppf (_, s) -> display_service ppf (_path, tpath, s))
ppf
(RPC_service.MethMap.bindings services)
in
let rec display ppf (path, tpath, tree) =
match tree with
| Dynamic description -> (
Format.fprintf ppf "- /%s <dynamic>" (String.concat "/" tpath) ;
match description with
| None | Some "" ->
()
| Some description ->
display_paragraph ppf description )
| Empty ->
()
| Static {services; subdirs = None} ->
display_services ppf (path, tpath, services)
| Static {services; subdirs = Some (Suffixes subdirs)} -> (
match
( RPC_service.MethMap.cardinal services,
Resto.StringMap.bindings subdirs )
with
| (0, []) ->
()
| (0, [(n, solo)]) ->
display ppf (path @ [n], tpath @ [n], solo)
| (_, items) when count tree >= 3 && path <> [] ->
Format.fprintf
ppf
"@[<v 2>+ %s/@,%a@]"
(String.concat "/" path)
(display_list tpath)
items
| (_, items) when count tree >= 3 && path <> [] ->
Format.fprintf
ppf
"@[<v 2>+ %s@,%a@,%a@]"
(String.concat "/" path)
display_services
(path, tpath, services)
(display_list tpath)
items
| (0, (n, t) :: items) ->
Format.fprintf ppf "%a" display (path @ [n], tpath @ [n], t) ;
List.iter
(fun (n, t) ->
Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t))
items
| (_, items) ->
display_services ppf (path, tpath, services) ;
List.iter
(fun (n, t) ->
Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t))
items )
| Static {services; subdirs = Some (Arg (arg, solo))}
when RPC_service.MethMap.cardinal services = 0 ->
collect arg ;
let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
display ppf (path @ [name], tpath @ [name], solo)
| Static {services; subdirs = Some (Arg (arg, solo))} ->
collect arg ;
display_services ppf (path, tpath, services) ;
Format.fprintf ppf "@," ;
let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
display ppf (path @ [name], tpath @ [name], solo)
and display_list tpath =
Format.pp_print_list (fun ppf (n, t) -> display ppf ([n], tpath @ [n], t))
in
cctxt#message
"@ @[<v 2>Available services:@ @ %a@]@."
display
(args, args, tree)
>>= fun () ->
if !collected_args <> [] then
cctxt#message
"@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
(Format.pp_print_list display_arg)
!collected_args
>>= fun () -> return_unit
else return_unit
let schema meth url (cctxt : #Client_context.full) =
let args = String.split '/' url in
let open RPC_description in
RPC_description.describe cctxt ~recurse:false args
>>=? function
| Static {services; _} -> (
match RPC_service.MethMap.find_opt meth services with
| None ->
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!"
>>= fun () -> return_unit
| Some {input = Some input; output; _} ->
let json =
`O
[ ("input", Json_schema.to_json (fst input));
("output", Json_schema.to_json (fst output)) ]
in
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
>>= fun () -> return_unit
| Some {input = None; output; _} ->
let json = `O [("output", Json_schema.to_json (fst output))] in
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
>>= fun () -> return_unit )
| _ ->
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!"
>>= fun () -> return_unit
let format binary meth url (cctxt : #Client_context.io_rpcs) =
let args = String.split '/' url in
let open RPC_description in
let pp =
if binary then fun ppf (_, schema) ->
Data_encoding.Binary_schema.pp ppf schema
else fun ppf (schema, _) -> Json_schema.pp ppf schema
in
RPC_description.describe cctxt ~recurse:false args
>>=? function
| Static {services; _} -> (
match RPC_service.MethMap.find_opt meth services with
| None ->
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!"
>>= fun () -> return_unit
| Some {input = Some input; output; _} ->
cctxt#message
"@[<v 0>@[<v 2>Input format:@,%a@]@,@[<v 2>Output format:@,%a@]@,@]"
pp
input
pp
output
>>= fun () -> return_unit
| Some {input = None; output; _} ->
cctxt#message "@[<v 0>@[<v 2>Output format:@,%a@]@,@]" pp output
>>= fun () -> return_unit )
| _ ->
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!"
>>= fun () -> return_unit
let fill_in ?(show_optionals = true) schema =
let open Json_schema in
match (root schema).kind with
| Null ->
Lwt.return_ok `Null
| Any | Object {properties = []; _} ->
Lwt.return_ok (`O [])
| _ ->
editor_fill_in ~show_optionals schema
let display_answer (cctxt : #Client_context.full) = function
| `Ok json ->
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
>>= fun () -> return_unit
| `Not_found _ ->
cctxt#message "No service found at this URL\n%!"
>>= fun () -> return_unit
| `Error (Some json) ->
cctxt#message
"@[<v 2>Command failed :@[ %a@]@]@."
(Format.pp_print_list Error_monad.pp)
(Data_encoding.Json.destruct
(Data_encoding.list Error_monad.error_encoding)
json)
>>= fun () -> return_unit
| `Error None | `Unauthorized _ | `Forbidden _ | `Conflict _ ->
cctxt#message "Unexpected server answer\n%!" >>= fun () -> return_unit
let call meth raw_url (cctxt : #Client_context.full) =
let uri = Uri.of_string raw_url in
let args = String.split_path (Uri.path uri) in
RPC_description.describe cctxt ~recurse:false args
>>=? function
| Static {services; _} -> (
match RPC_service.MethMap.find_opt meth services with
| None ->
cctxt#message
"No service found at this URL with this method (but this is a valid \
prefix)\n\
%!"
>>= fun () -> return_unit
| Some {input = None; _} ->
cctxt#generic_json_call meth uri >>=? display_answer cctxt
| Some {input = Some input; _} -> (
fill_in ~show_optionals:false (fst input)
>>= function
| Error msg ->
cctxt#error "%s" msg >>= fun () -> return_unit
| Ok json ->
cctxt#generic_json_call meth ~body:json uri
>>=? display_answer cctxt ) )
| _ ->
cctxt#message "No service found at this URL\n%!"
>>= fun () -> return_unit
let call_with_json meth raw_url json (cctxt : #Client_context.full) =
let uri = Uri.of_string raw_url in
match Data_encoding.Json.from_string json with
| exception Assert_failure _ ->
(* Ref : https://github.com/mirage/ezjsonm/issues/31 *)
cctxt#error
"Failed to parse the provided json: unwrapped JSON value.\n%!"
| Error err ->
cctxt#error "Failed to parse the provided json: %s\n%!" err
| Ok body ->
cctxt#generic_json_call meth ~body uri >>=? display_answer cctxt
let call_with_file_or_json meth url maybe_file (cctxt : #Client_context.full) =
( match TzString.split ':' ~limit:1 maybe_file with
| ["file"; filename] ->
(* Mostly copied from src/client/client_aliases.ml *)
Lwt.catch
(fun () ->
Lwt_io.(with_file ~mode:Input filename read)
>>= fun content -> return content)
(fun exn -> failwith "cannot read file (%s)" (Printexc.to_string exn))
| _ ->
return maybe_file )
>>=? fun json -> call_with_json meth url json cctxt
let meth_params ?(name = "HTTP method") ?(desc = "") params =
param
~name
~desc
(parameter
~autocomplete:(fun _ ->
return
@@ List.map String.lowercase_ascii
@@ List.map Resto.string_of_meth
@@ [`GET; `POST; `DELETE; `PUT; `PATCH])
(fun _ name ->
match Resto.meth_of_string (String.uppercase_ascii name) with
| None ->
failwith "Unknown HTTP method: %s" name
| Some meth ->
return meth))
params
let group = {Clic.name = "rpc"; title = "Commands for the low level RPC layer"}
let commands =
[ command
~group
~desc:
"List RPCs under a given URL prefix.\n\
Some parts of the RPC service hierarchy depend on parameters,\n\
they are marked by a suffix `<dynamic>`.\n\
You can list these sub-hierarchies by providing a concrete URL \
prefix whose arguments are set to a valid value."
no_options
( prefixes ["rpc"; "list"]
@@ string ~name:"url" ~desc:"the URL prefix"
@@ stop )
(fun () -> list);
command
~group
~desc:"Alias to `rpc list /`."
no_options
(prefixes ["rpc"; "list"] @@ stop)
(fun () -> list "/");
command
~group
~desc:"Get the input and output JSON schemas of an RPC."
no_options
( prefixes ["rpc"; "schema"]
@@ meth_params
@@ string ~name:"url" ~desc:"the RPC url"
@@ stop )
(fun () -> schema);
command
~group
~desc:"Get the humanoid readable input and output formats of an RPC."
(args1 (switch ~doc:"Binary format" ~short:'b' ~long:"binary" ()))
( prefixes ["rpc"; "format"]
@@ meth_params
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
format;
command
~group
~desc:"Call an RPC with the GET method."
no_options
( prefixes ["rpc"; "get"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
(fun () -> call `GET);
command
~group
~desc:
"Call an RPC with the POST method.\n\
It invokes $EDITOR if input data is needed."
no_options
( prefixes ["rpc"; "post"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
(fun () -> call `POST);
command
~group
~desc:
"Call an RPC with the POST method, providing input data via the \
command line."
no_options
( prefixes ["rpc"; "post"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ prefix "with"
@@ string
~name:"input"
~desc:
"the raw JSON input to the RPC\n\
For instance, use `{}` to send the empty document.\n\
Alternatively, use `file:path` to read the JSON data from a file."
@@ stop )
(fun () -> call_with_file_or_json `POST);
command
~group
~desc:
"Call an RPC with the PUT method.\n\
It invokes $EDITOR if input data is needed."
no_options
( prefixes ["rpc"; "put"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
(fun () -> call `PUT);
command
~group
~desc:
"Call an RPC with the PUT method, providing input data via the \
command line."
no_options
( prefixes ["rpc"; "put"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ prefix "with"
@@ string
~name:"input"
~desc:
"the raw JSON input to the RPC\n\
For instance, use `{}` to send the empty document.\n\
Alternatively, use `file:path` to read the JSON data from a file."
@@ stop )
(fun () -> call_with_file_or_json `PUT);
command
~group
~desc:"Call an RPC with the DELETE method."
no_options
( prefixes ["rpc"; "delete"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
(fun () -> call `DELETE) ]
src/bin_client/client_rpc_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Import Clic.
Import Json_schema.
(* ❌ The definition of exceptions is not handled. *)
exception
Record input := {
int : Z -> Z -> (option string) -> (list string) -> Lwt.t Z;
float : (option string) -> (list string) -> Lwt.t Z;
string : (option string) -> (list string) -> Lwt.t string;
bool : (option string) -> (list string) -> Lwt.t bool;
continue : (option string) -> (list string) -> Lwt.t bool;
display : string -> Lwt.t unit }.
Definition fill_in (op_staroptstar : option bool)
: input -> Json_schema.schema -> Lwt.t variant :=
let show_optionals :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun input =>
fun schema =>
let fix element
(path : list string) (function_parameter : Json_schema.element)
: Lwt.t variant :=
let '{| title := title; kind := kind |} := function_parameter in
match kind with
| Json_schema.Integer {| minimum := minimum; maximum := maximum |} =>
let minimum :=
match minimum with
| None => Stdlib.min_int
| Some (m, Inclusive) => Stdlib.int_of_float m
| Some (m, Exclusive) => Z.add (Stdlib.int_of_float m) 1
end in
let maximum :=
match maximum with
| None => Stdlib.max_int
| Some (m, Inclusive) => Stdlib.int_of_float m
| Some (m, Exclusive) => Z.sub (Stdlib.int_of_float m) 1
end in
op_gtgteq ((int input) minimum maximum title path)
(fun i =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Number _ =>
op_gtgteq ((float input) title path)
(fun f =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Boolean =>
op_gtgteq ((bool input) title path)
(fun f =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.String _ =>
op_gtgteq ((string input) title path)
(fun f =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Combine (Json_schema.One_of | Json_schema.Any_of) elts =>
let nb := List.length elts in
op_gtgteq
((int input) 0 (Z.sub nb 1)
(Some "Select the schema to follow" % string) path)
(fun n => element path (List.nth elts n))
| Json_schema.Combine (Json_schema.All_of | Json_schema.Not) _ =>
Lwt.fail Unsupported_construct
| Json_schema.Def_ref name =>
Lwt._return
(* ❌ Variants not supported *)
variant
| Json_schema.Id_ref _ | Json_schema.Ext_ref _ =>
Lwt.fail Unsupported_construct
| Json_schema.Array elts _ =>
let fix fill_loop
(acc : list variant) (n : Z) (ls : list Json_schema.element)
: Lwt.t (list variant) :=
match ls with
| [] => Lwt._return acc
| cons elt elts =>
op_gtgteq (element (cons (OCaml.Stdlib.string_of_int n) path) elt)
(fun json => fill_loop (cons json acc) (Z.succ n) elts)
end in
op_gtgteq (fill_loop [] 0 elts)
(fun acc =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Object {| properties := properties |} =>
let properties :=
if show_optionals then
properties
else
List.filter
(fun function_parameter =>
let '(_, _, b, _) := function_parameter in
b) properties in
let fix fill_loop {A B : Type}
(acc : list (string * variant)) (ls :
list (string * Json_schema.element * A * B))
: Lwt.t (list (string * variant)) :=
match ls with
| [] => Lwt._return acc
| cons (n, elt, _, _) elts =>
op_gtgteq (element (cons n path) elt)
(fun json => fill_loop (cons (n, json) acc) elts)
end in
op_gtgteq (fill_loop [] properties)
(fun acc =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Monomorphic_array elt specs =>
let fix fill_loop (acc : list variant) (min : Z) (n : Z) (max : Z)
: Lwt.t (list variant) :=
if OCaml.Stdlib.gt n max then
Lwt._return acc
else
op_gtgteq (element (cons (OCaml.Stdlib.string_of_int n) path) elt)
(fun json =>
op_gtgteq
(if OCaml.Stdlib.lt n min then
Lwt.return_true
else
(continue input) title path)
(fun function_parameter =>
match function_parameter with
| true => fill_loop (cons json acc) min (Z.succ n) max
| false => Lwt._return (cons json acc)
end)) in
let max :=
match max_items specs with
| None => Stdlib.max_int
| Some m => m
end in
op_gtgteq (fill_loop [] (min_items specs) 0 max)
(fun acc =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Any => Lwt.fail Unsupported_construct
| Json_schema.Dummy => Lwt.fail Unsupported_construct
| Json_schema.Null =>
Lwt._return
(* ❌ Variants not supported *)
variant
end in
element [] (Json_schema.root schema).
Definition random_fill_in (op_staroptstar : option bool)
: Json_schema.schema -> Lwt.t (Result.result variant string) :=
let show_optionals :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun schema =>
let display {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
Lwt.return_unit in
let int {A B : Type} (min : Z) (max : Z) (function_parameter : A)
: B -> Lwt.t Z :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
let max : int64 :=
Int64.of_int max
with min : int64 :=
Int64.of_int min in
let range := Int64.sub max min in
let random_int64 := Int64.add (Random.int64 range) min in
Lwt._return (Int64.to_int random_int64) in
let string {A B : Type} (_title : A) (function_parameter : B)
: Lwt.t string :=
let '_ := function_parameter in
Lwt._return "" % string in
let float {A B : Type} (function_parameter : A) : B -> Lwt.t Z :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt._return (Random.float Stdlib.infinity) in
let bool {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt._return (equiv_decb (Random.int 2) 0) in
let continue {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt._return (equiv_decb (Random.int 4) 0) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(fill_in (Some show_optionals)
{| int := Z; float := Z; string := string; bool := bool;
continue := continue; display := display |} schema)
(fun json => Lwt.return_ok json))
(fun e =>
let msg :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Fill-in failed " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"Fill-in failed %s
%!" % string) (Printexc.to_string e) in
Lwt.return_error msg).
Definition editor_fill_in (op_staroptstar : option bool)
: Json_schema.schema ->
Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let show_optionals :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun schema =>
let tmp :=
Filename.temp_file None "tezos_rpc_call_" % string ".json" % string in
let fix init (function_parameter : unit)
: Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let 'tt := function_parameter in
op_gtgteq (random_fill_in (Some show_optionals) schema)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error msg => Lwt.return_error msg
| Stdlib.Ok json =>
op_gtgteq
(with_file None None None Lwt_io.Output tmp
(fun fp =>
write_line fp (Data_encoding.Json.to_string None None json)))
(fun function_parameter =>
let 'tt := function_parameter in
edit tt)
end)
with edit (function_parameter : unit)
: Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let 'tt := function_parameter in
let editor_cmd :=
let ed :=
match
((Sys.getenv_opt "EDITOR" % string),
(Sys.getenv_opt "VISUAL" % string)) with
| (Some ed, _) => ed
| (None, Some ed) => ed
| (None, None) => "notepad.exe" % string
| _ => "nano" % string
end in
Lwt_process.shell (String.append ed (String.append " " % string tmp)) in
op_gtgteq
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
match function_parameter with
| Unix.WEXITED 0 =>
op_gtgteq (reread tt)
(fun json =>
op_gtgteq (delete tt)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return json))
| Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x =>
let msg :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "FAILED " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal "
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"FAILED %d
%!" % string) x in
op_gtgteq (delete tt)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_error msg)
end)
with reread (function_parameter : unit)
: Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let 'tt := function_parameter in
op_gtgteq
(with_file None None None Lwt_io.Input tmp (fun fp => read None fp))
(fun text =>
match Data_encoding.Json.from_string text with
| Stdlib.Ok r => Lwt.return_ok r
| Stdlib.Error msg =>
Lwt.return_error
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"bad input: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"bad input: %s" % string) msg)
end)
with delete (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
Lwt_unix.unlink tmp in
init tt.
Fixpoint count {A : Type}
(function_parameter : Tezos_base__TzPervasives.RPC_description.directory A)
: Z :=
match function_parameter with
| Tezos_base__TzPervasives.RPC_description.Empty => 0
| Tezos_base__TzPervasives.RPC_description.Dynamic _ => 1
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services; subdirs := subdirs |} =>
let service := RPC_service.MethMap.cardinal services in
let subdirs :=
match subdirs with
| None => 0
| Some (Tezos_base__TzPervasives.RPC_description.Suffixes subdirs) =>
Resto.StringMap.(Stdlib__map.S.fold)
(fun function_parameter =>
let '_ := function_parameter in
fun t => fun r => Z.add r (count t)) subdirs 0
| Some (Tezos_base__TzPervasives.RPC_description.Arg _ subdir) =>
count subdir
end in
Z.add service subdirs
end.
Definition list {F G I a b i o p q : Type}
(url : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let args := String.split "/" % char None None url in
op_gtgteqquestion (RPC_description.describe cctxt (Some true) args)
(fun tree =>
let collected_args := Stdlib.ref [] in
let collect (arg : Tezos_base__TzPervasives.RPC_arg.descr) : unit :=
if
negb
(andb (nequiv_decb (RPC_arg.descr arg) None)
(List.mem arg (Stdlib.op_exclamation collected_args))) then
Stdlib.op_coloneq collected_args
(cons arg (Stdlib.op_exclamation collected_args))
else
tt in
let display_paragraph
(ppf : Stdlib.Format.formatter) (description : string) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@, @[%a@]" % string)
(fun ppf =>
fun words =>
List.iter
(Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)) "%s@ " % string))
words) (String.split " " % char None None description) in
let display_arg
(ppf : Stdlib.Format.formatter) (arg :
Tezos_base__TzPervasives.RPC_arg.descr) : unit :=
match RPC_arg.descr arg with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(RPC_arg.name arg)
| Some descr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "<" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ">" % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"<%s>%a" % string) (RPC_arg.name arg) display_paragraph descr
end in
let display_service {J K : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
J * (list string) * (Tezos_base__TzPervasives.RPC_description.service K))
: unit :=
let '(_path, tpath, service) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " /" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"- %s /%s" % string) (RPC_service.string_of_meth (meth service))
(String.concat "/" % string tpath) in
match description service with
| None | Some "" % string => tt
| Some description => display_paragraph ppf description
end in
let display_services {J K : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
J * (list string) *
(Tezos_base__TzPervasives.RPC_service.MethMap.t
(Tezos_base__TzPervasives.RPC_description.service K))) : unit :=
let '(_path, tpath, services) := function_parameter in
Format.pp_print_list None
(fun ppf =>
fun function_parameter =>
let '(_, s) := function_parameter in
display_service ppf (_path, tpath, s)) ppf
(RPC_service.MethMap.bindings services) in
let fix display {J : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
(list Resto.StringMap.(Stdlib__map.S.key)) *
(list Resto.StringMap.(Stdlib__map.S.key)) *
(Tezos_base__TzPervasives.RPC_description.directory J)) : unit :=
let '(path, tpath, tree) := function_parameter in
match tree with
| Tezos_base__TzPervasives.RPC_description.Dynamic description =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "- /" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" <dynamic>" % string
CamlinternalFormatBasics.End_of_format)))
"- /%s <dynamic>" % string) (String.concat "/" % string tpath)
in
match description with
| None | Some "" % string => tt
| Some description => display_paragraph ppf description
end
| Tezos_base__TzPervasives.RPC_description.Empty => tt
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services; subdirs := None |} =>
display_services ppf (path, tpath, services)
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services;
subdirs :=
Some
(Tezos_base__TzPervasives.RPC_description.Suffixes
subdirs)
|} =>
match
((RPC_service.MethMap.cardinal services),
(Resto.StringMap.(Stdlib__map.S.bindings) subdirs)) with
| (0, []) => tt
| (0, cons (n, solo) []) =>
display ppf
((OCaml.Stdlib.app path (cons n [])),
(OCaml.Stdlib.app tpath (cons n [])), solo)
| (_, items) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "+ " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "/" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>+ %s/@,%a@]" % string) (String.concat "/" % string path)
(display_list tpath) items
| (_, items) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "+ " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 2>+ %s@,%a@,%a@]" % string)
(String.concat "/" % string path) display_services
(path, tpath, services) (display_list tpath) items
| (0, cons (n, t) items) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
display
((OCaml.Stdlib.app path (cons n [])),
(OCaml.Stdlib.app tpath (cons n [])), t) in
List.iter
(fun function_parameter =>
let '(n, t) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "@,%a" % string)
display
((OCaml.Stdlib.app path (cons n [])),
(OCaml.Stdlib.app tpath (cons n [])), t)) items
| (_, items) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := display_services ppf (path, tpath, services) in
List.iter
(fun function_parameter =>
let '(n, t) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "@,%a" % string)
display
((OCaml.Stdlib.app path (cons n [])),
(OCaml.Stdlib.app tpath (cons n [])), t)) items
end
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services;
subdirs :=
Some
(Tezos_base__TzPervasives.RPC_description.Arg
arg solo)
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := collect arg in
let name :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "<" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ">" % char
CamlinternalFormatBasics.End_of_format))) "<%s>" % string)
(RPC_arg.name arg) in
display ppf
((OCaml.Stdlib.app path (cons name [])),
(OCaml.Stdlib.app tpath (cons name [])), solo)
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services;
subdirs :=
Some
(Tezos_base__TzPervasives.RPC_description.Arg
arg solo)
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := collect arg in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := display_services ppf (path, tpath, services) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string) in
let name :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "<" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ">" % char
CamlinternalFormatBasics.End_of_format))) "<%s>" % string)
(RPC_arg.name arg) in
display ppf
((OCaml.Stdlib.app path (cons name [])),
(OCaml.Stdlib.app tpath (cons name [])), solo)
end
with display_list {J : Type}
(tpath : list Resto.StringMap.(Stdlib__map.S.key))
: Stdlib.Format.formatter ->
(list
(Resto.StringMap.(Stdlib__map.S.key) *
(Tezos_base__TzPervasives.RPC_description.directory J))) -> unit :=
Format.pp_print_list None
(fun ppf =>
fun function_parameter =>
let '(n, t) := function_parameter in
display ppf ((cons n []), (OCaml.Stdlib.app tpath (cons n [])), t))
in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Available services:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"@ @[<v 2>Available services:@ @ %a@]@." % string) display
(args, args, tree))
(fun function_parameter =>
let 'tt := function_parameter in
if nequiv_decb (Stdlib.op_exclamation collected_args) [] then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Dynamic parameter description:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"@,@[<v 2>Dynamic parameter description:@ @ %a@]@." % string)
(Format.pp_print_list None display_arg)
(Stdlib.op_exclamation collected_args))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
else
return_unit)).
Definition schema {F G I a b i o p q : Type}
(meth : Tezos_base__TzPervasives.RPC_service.MethMap.key) (url : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let args := String.split "/" % char None None url in
op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services |} =>
match RPC_service.MethMap.find_opt meth services with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL (but this is a valid prefix)
" %
string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL (but this is a valid prefix)
%!" %
string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := Some input; output := output |} =>
let json :=
(* ❌ Variants not supported *)
variant in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
(pp None None Ezjsonm) json)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := None; output := output |} =>
let json :=
(* ❌ Variants not supported *)
variant in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
(pp None None Ezjsonm) json)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end
| _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL (but this is a valid prefix)
" %
string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL (but this is a valid prefix)
%!" %
string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end).
Definition format {E F I a b i o p q : Type}
(binary : bool) (meth : Tezos_base__TzPervasives.RPC_service.MethMap.key)
(url : string)
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(F * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
(Uri.t *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) * I))))))))))) * I)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let args := String.split "/" % char None None url in
let pp :=
if binary then
fun ppf =>
fun function_parameter =>
let '(_, schema) := function_parameter in
Data_encoding.Binary_schema.pp ppf schema
else
fun ppf =>
fun function_parameter =>
let '(schema, _) := function_parameter in
Json_schema.pp ppf schema in
op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services |} =>
match RPC_service.MethMap.find_opt meth services with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL (but this is a valid prefix)
" %
string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL (but this is a valid prefix)
%!" %
string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := Some input; output := output |} =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Input format:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Output format:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"@[<v 0>@[<v 2>Input format:@,%a@]@,@[<v 2>Output format:@,%a@]@,@]"
% string) pp input pp output)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := None; output := output |} =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Output format:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 0>@[<v 2>Output format:@,%a@]@,@]" % string) pp output)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end
| _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL (but this is a valid prefix)
" %
string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL (but this is a valid prefix)
%!" %
string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end).
Definition fill_in (op_staroptstar : option bool)
: Json_schema.schema ->
Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let show_optionals :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun schema =>
match kind (root schema) with
| Json_schema.Null =>
Lwt.return_ok
(* ❌ Variants not supported *)
variant
| Json_schema.Any | Json_schema.Object {| properties := [] |} =>
Lwt.return_ok
(* ❌ Variants not supported *)
variant
| _ => editor_fill_in (Some show_optionals) schema
end.
Definition display_answer {F G I a b i o p q : Type}
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (function_parameter : variant)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| Ok json =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) (pp None None Ezjsonm) json)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Not_found _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL
%!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Error (Some json) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Command failed :" % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 2>Command failed :@[ %a@]@]@." % string)
(Format.pp_print_list None Error_monad.pp)
(Data_encoding.Json.destruct
(Data_encoding.list None Error_monad.error_encoding) json))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Error None | Unauthorized _ | Forbidden _ | Conflict _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unexpected server answer
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"Unexpected server answer
%!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end.
Definition call {F G I a b i o p q : Type}
(meth : Tezos_base__TzPervasives.RPC_service.MethMap.key) (raw_url : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let uri := Uri.of_string raw_url in
let args := String.split_path (Uri.path uri) in
op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services |} =>
match RPC_service.MethMap.find_opt meth services with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL with this method (but this is a valid prefix)
"
% string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL with this method (but this is a valid prefix)
%!"
% string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := None |} =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send meth None uri) (display_answer cctxt)
| Some {| input := Some input |} =>
op_gtgteq (fill_in (Some false) (fst input))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error msg =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
msg)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Ok json =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send meth (Some json) uri) (display_answer cctxt)
end)
end
| _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL
%!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end).
Definition call_with_json {F G I a b i o p q : Type}
(meth : Tezos_rpc.RPC_service.meth) (raw_url : string) (json : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let uri := Uri.of_string raw_url in
match Data_encoding.Json.from_string json with
| Stdlib.Error err =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to parse the provided json: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"Failed to parse the provided json: %s
%!" % string) err
| Stdlib.Ok body =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send meth (Some body) uri) (display_answer cctxt)
end.
Definition call_with_file_or_json {F G I a b i o p q : Type}
(meth : Tezos_rpc.RPC_service.meth) (url : string) (maybe_file : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
match TzString.split ":" % char None (Some 1) maybe_file with
| cons "file" % string (cons filename []) =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(with_file None None None Lwt_io.Input filename
(let arg := read in
fun eta => arg None eta)) (fun content => _return content))
(fun exn =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"cannot read file (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"cannot read file (%s)" % string) (Printexc.to_string exn))
| _ => _return maybe_file
end (fun json => call_with_json meth url json cctxt).
Definition meth_params {A B : Type} (op_staroptstar : option string)
: (option string) ->
(Tezos_base__TzPervasives.Clic.params A B) ->
Tezos_base__TzPervasives.Clic.params (variant -> A) B :=
let name :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "HTTP method" % string
end in
fun op_staroptstar =>
let desc :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun params =>
param name desc
(parameter
(Some
(fun function_parameter =>
let '_ := function_parameter in
apply _return
(apply (List.map String.lowercase_ascii)
(apply (List.map Resto.string_of_meth)
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])))))))))
(fun function_parameter =>
let '_ := function_parameter in
fun name =>
match Resto.meth_of_string (String.uppercase_ascii name) with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown HTTP method: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Unknown HTTP method: %s" % string) name
| Some meth => _return meth
end)) params.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "rpc" % string;
Clic.title := "Commands for the low level RPC layer" % string |}.
Definition commands {F G I a b i o p q : Type}
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
cons
(command (Some group)
"List RPCs under a given URL prefix.
Some parts of the RPC service hierarchy depend on parameters,
they are marked by a suffix `<dynamic>`.
You can list these sub-hierarchies by providing a concrete URL prefix whose arguments are set to a valid value."
% string no_options
(apply (prefixes (cons "rpc" % string (cons "list" % string [])))
(apply (string "url" % string "the URL prefix" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
list))
(cons
(command (Some group) "Alias to `rpc list /`." % string no_options
(apply (prefixes (cons "rpc" % string (cons "list" % string []))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
list "/" % string))
(cons
(command (Some group)
"Get the input and output JSON schemas of an RPC." % string no_options
(apply (prefixes (cons "rpc" % string (cons "schema" % string [])))
(apply
(let arg := meth_params in
fun eta => arg None None eta)
(apply (string "url" % string "the RPC url" % string) stop)))
(fun function_parameter =>
let 'tt := function_parameter in
schema))
(cons
(command (Some group)
"Get the humanoid readable input and output formats of an RPC." %
string
(args1
(switch "Binary format" % string (Some "b" % char)
"binary" % string tt))
(apply (prefixes (cons "rpc" % string (cons "format" % string [])))
(apply
(let arg := meth_params in
fun eta => arg None None eta)
(apply (string "url" % string "the RPC URL" % string) stop)))
format)
(cons
(command (Some group) "Call an RPC with the GET method." % string
no_options
(apply (prefixes (cons "rpc" % string (cons "get" % string [])))
(apply (string "url" % string "the RPC URL" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
call
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the POST method.
It invokes $EDITOR if input data is needed."
% string no_options
(apply
(prefixes (cons "rpc" % string (cons "post" % string [])))
(apply (string "url" % string "the RPC URL" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
call
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the POST method, providing input data via the command line."
% string no_options
(apply
(prefixes (cons "rpc" % string (cons "post" % string [])))
(apply (string "url" % string "the RPC URL" % string)
(apply (prefix "with" % string)
(apply
(string "input" % string
"the raw JSON input to the RPC
For instance, use `{}` to send the empty document.
Alternatively, use `file:path` to read the JSON data from a file."
% string) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
call_with_file_or_json
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the PUT method.
It invokes $EDITOR if input data is needed."
% string no_options
(apply
(prefixes (cons "rpc" % string (cons "put" % string [])))
(apply (string "url" % string "the RPC URL" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
call
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the PUT method, providing input data via the command line."
% string no_options
(apply
(prefixes (cons "rpc" % string (cons "put" % string [])))
(apply (string "url" % string "the RPC URL" % string)
(apply (prefix "with" % string)
(apply
(string "input" % string
"the raw JSON input to the RPC
For instance, use `{}` to send the empty document.
Alternatively, use `file:path` to read the JSON data from a file."
% string) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
call_with_file_or_json
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the DELETE method." % string
no_options
(apply
(prefixes
(cons "rpc" % string (cons "delete" % string [])))
(apply (string "url" % string "the RPC URL" % string)
stop))
(fun function_parameter =>
let 'tt := function_parameter in
call
(* ❌ Variants not supported *)
variant)) []))))))))).
src/bin_client/main_admin.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "admin-client.main"
end)
let select_commands _ _ =
return
(List.flatten
[ Client_report_commands.commands ();
Client_admin_commands.commands ();
Client_p2p_commands.commands ();
Client_protocols_commands.commands ();
Client_rpc_commands.commands;
Client_event_logging_commands.commands () ])
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module Client_config)
~select_commands
src/bin_client/main_admin.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition select_commands {A B : Type} (function_parameter : A)
: B ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full))) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
_return
(List.flatten
(cons (Client_report_commands.commands tt)
(cons (Client_admin_commands.commands tt)
(cons (Client_p2p_commands.commands tt)
(cons (Client_protocols_commands.commands tt)
(cons Client_rpc_commands.commands
(cons (Client_event_logging_commands.commands tt) []))))))).
src/bin_client/main_client.ml 25 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "client.main"
end)
open Client_config
let disable_disclaimer =
match Sys.getenv_opt "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" with
| Some ("yes" | "y" | "YES" | "Y") ->
true
| _ ->
false
let zeronet () =
if not disable_disclaimer then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
@,\
\ This is @{<warning>NOT@} the Tezos Mainnet.@,\
@,\
\ The node you are connecting to claims to be running on the@,\
\ @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
Zeronet is a testing network, with free tokens and frequent resets.@]@\n\
@."
let alphanet () =
if not disable_disclaimer then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
@,\
\ This is @{<warning>NOT@} the Tezos Mainnet.@,\
@,\
\ The node you are connecting to claims to be running on the@,\
\ @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
\ Alphanet is a testing network, with free tokens.@]@\n\
@."
let mainnet () =
if not disable_disclaimer then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Disclaimer@}@}@,\
The Tezos network is a new blockchain technology.@,\
Users are solely responsible for any risks associated@,\
with usage of the Tezos network. Users should do their@,\
own research to determine if Tezos is the appropriate@,\
platform for their needs and should apply judgement and@,\
care in their network interactions.@]@\n\
@."
let sandbox () =
if not disable_disclaimer then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
@,\
\ The node you are connecting to claims to be running in a@,\
\ @{<warning>Tezos TEST SANDBOX@}.@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
You should not see this message if you are not a developer.@]@\n\
@."
let check_network ctxt =
Shell_services.P2p.version ctxt
>>= function
| Error _ ->
Lwt.return_none
| Ok version ->
let has_prefix prefix =
String.has_prefix ~prefix (version.chain_name :> string)
in
if has_prefix "SANDBOXED" then (
sandbox () ;
Lwt.return_some `Sandbox )
else if has_prefix "TEZOS_ZERONET" then (
zeronet () ;
Lwt.return_some `Zeronet )
else if has_prefix "TEZOS_ALPHANET" then (
alphanet () ;
Lwt.return_some `Alphanet )
else if has_prefix "TEZOS_BETANET" || has_prefix "TEZOS_MAINNET" then (
mainnet () ;
Lwt.return_some `Mainnet )
else Lwt.return_none
let get_commands_for_version ctxt network chain block protocol =
Shell_services.Blocks.protocols ctxt ~chain ~block ()
>>= function
| Ok {next_protocol = version; _} -> (
match protocol with
| None ->
return
(Some version, Client_commands.commands_for_version version network)
| Some given_version ->
if not (Protocol_hash.equal version given_version) then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
The protocol provided via `--protocol` (%a)@,\
is not the one retrieved from the node (%a).@]@\n\
@."
Protocol_hash.pp_short
given_version
Protocol_hash.pp_short
version ;
return
( Some version,
Client_commands.commands_for_version given_version network ) )
| Error errs -> (
match protocol with
| None ->
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
Failed to acquire the protocol version from the node@,\
%a@]@\n\
@."
(Format.pp_print_list pp)
errs ;
return (None, [])
| Some version ->
return
(Some version, Client_commands.commands_for_version version network)
)
let select_commands ctxt {chain; block; protocol; _} =
check_network ctxt
>>= fun network ->
get_commands_for_version ctxt network chain block protocol
>>|? fun (_, commands_for_version) ->
Client_rpc_commands.commands
@ Tezos_signer_backends_unix.Ledger.commands ()
@ Client_keys_commands.commands network
@ Client_helpers_commands.commands ()
@ commands_for_version
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module Client_config)
~select_commands
src/bin_client/main_client.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Import Client_config.
Definition disable_disclaimer : bool :=
match Sys.getenv_opt "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" % string with
| Some ("yes" % string | "y" % string | "YES" % string | "Y" % string) => true
| _ => false
end.
Definition zeronet (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if negb disable_disclaimer then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" This is " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" the Tezos Mainnet." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" The node you are connecting to claims to be running on the"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"Tezos Zeronet DEVELOPMENT NETWORK"
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" Do " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" %
string
CamlinternalFormatBasics.End_of_format)
"<warning>" %
string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" use your fundraiser keys on this network."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," %
string 0 0)
(CamlinternalFormatBasics.String_literal
"Zeronet is a testing network, with free tokens and frequent resets."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@, This is @{<warning>NOT@} the Tezos Mainnet.@,@, The node you are connecting to claims to be running on the@, @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@, Do @{<warning>NOT@} use your fundraiser keys on this network.@,Zeronet is a testing network, with free tokens and frequent resets.@]@
@."
% string)
else
tt.
Definition alphanet (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if negb disable_disclaimer then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" This is " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" the Tezos Mainnet." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" The node you are connecting to claims to be running on the"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"Tezos Alphanet DEVELOPMENT NETWORK."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" Do " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" %
string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" use your fundraiser keys on this network."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string
0 0)
(CamlinternalFormatBasics.String_literal
" Alphanet is a testing network, with free tokens."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@, This is @{<warning>NOT@} the Tezos Mainnet.@,@, The node you are connecting to claims to be running on the@, @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@, Do @{<warning>NOT@} use your fundraiser keys on this network.@, Alphanet is a testing network, with free tokens.@]@
@."
% string)
else
tt.
Definition mainnet (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if negb disable_disclaimer then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Disclaimer" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"The Tezos network is a new blockchain technology."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Users are solely responsible for any risks associated"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"with usage of the Tezos network. Users should do their"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.String_literal
"own research to determine if Tezos is the appropriate"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"platform for their needs and should apply judgement and"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"care in their network interactions."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))))))))))
"@[<v 2>@{<warning>@{<title>Disclaimer@}@}@,The Tezos network is a new blockchain technology.@,Users are solely responsible for any risks associated@,with usage of the Tezos network. Users should do their@,own research to determine if Tezos is the appropriate@,platform for their needs and should apply judgement and@,care in their network interactions.@]@
@."
% string)
else
tt.
Definition sandbox (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if negb disable_disclaimer then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" The node you are connecting to claims to be running in a"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"Tezos TEST SANDBOX" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" Do " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" use your fundraiser keys on this network."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"You should not see this message if you are not a developer."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@, The node you are connecting to claims to be running in a@, @{<warning>Tezos TEST SANDBOX@}.@, Do @{<warning>NOT@} use your fundraiser keys on this network.@,You should not see this message if you are not a developer.@]@
@."
% string)
else
tt.
Definition check_network {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) : Lwt.t (option variant) :=
op_gtgteq (Shell_services.P2p.version ctxt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ => Lwt.return_none
| Stdlib.Ok version =>
let has_prefix (prefix : string) : bool :=
String.has_prefix prefix (chain_name version) in
if has_prefix "SANDBOXED" % string then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := sandbox tt in
Lwt.return_some
(* ❌ Variants not supported *)
variant
else
if has_prefix "TEZOS_ZERONET" % string then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := zeronet tt in
Lwt.return_some
(* ❌ Variants not supported *)
variant
else
if has_prefix "TEZOS_ALPHANET" % string then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := alphanet tt in
Lwt.return_some
(* ❌ Variants not supported *)
variant
else
if
orb (has_prefix "TEZOS_BETANET" % string)
(has_prefix "TEZOS_MAINNET" % string) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := mainnet tt in
Lwt.return_some
(* ❌ Variants not supported *)
variant
else
Lwt.return_none
end).
Definition get_commands_for_version {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(network : option Tezos_client_commands.Client_commands.network)
(chain : Tezos_shell_services__Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
(protocol : option Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((option Tezos_base__TzPervasives.Protocol_hash.t) *
(list Tezos_client_commands.Client_commands.command))) :=
op_gtgteq (Shell_services.Blocks.protocols ctxt (Some chain) (Some block) tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok {| next_protocol := version |} =>
match protocol with
| None =>
_return
((Some version),
(Client_commands.commands_for_version version network))
| Some given_version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Protocol_hash.equal version given_version) then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"The protocol provided via `--protocol` (" %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"is not the one retrieved from the node ("
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
")." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,The protocol provided via `--protocol` (%a)@,is not the one retrieved from the node (%a).@]@
@."
% string) Protocol_hash.pp_short given_version
Protocol_hash.pp_short version
else
tt in
_return
((Some version),
(Client_commands.commands_for_version given_version network))
end
| Stdlib.Error errs =>
match protocol with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Failed to acquire the protocol version from the node"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,Failed to acquire the protocol version from the node@,%a@]@
@."
% string) (Format.pp_print_list None pp) errs in
_return (None, [])
| Some version =>
_return
((Some version),
(Client_commands.commands_for_version version network))
end
end).
Definition select_commands {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(function_parameter : Tezos_client_base_unix.Client_config.cli_args)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_client_commands.Client_commands.command)) :=
let '{| chain := chain; block := block; protocol := protocol |} :=
function_parameter in
op_gtgteq (check_network ctxt)
(fun network =>
op_gtgtpipequestion
(get_commands_for_version ctxt network chain block protocol)
(fun function_parameter =>
let '(_, commands_for_version) := function_parameter in
OCaml.Stdlib.app Client_rpc_commands.commands
(OCaml.Stdlib.app (Tezos_signer_backends_unix.Ledger.commands tt)
(OCaml.Stdlib.app (Client_keys_commands.commands network)
(OCaml.Stdlib.app (Client_helpers_commands.commands tt)
commands_for_version))))).
src/bin_client/test/proto_test_injection/main.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type block_header_data = MBytes.t
type block_header = {
shell : Block_header.shell_header;
protocol_data : block_header_data;
}
let block_header_data_encoding =
Data_encoding.(obj1 (req "random_data" Variable.bytes))
type block_header_metadata = unit
let block_header_metadata_encoding = Data_encoding.unit
type operation_data = unit
let operation_data_encoding = Data_encoding.unit
type operation_receipt = unit
let operation_receipt_encoding = Data_encoding.unit
let operation_data_and_receipt_encoding =
Data_encoding.conv
(function ((), ()) -> ())
(fun () -> ((), ()))
Data_encoding.unit
type operation = {
shell : Operation.shell_header;
protocol_data : operation_data;
}
let max_block_length = 42
let max_operation_data_length = 42
let validation_passes = []
let acceptable_passes _op = []
let compare_operations _ _ = 0
type validation_state = {context : Context.t; fitness : Int64.t}
let current_context {context} = return context
module Fitness = struct
type error += Invalid_fitness
type error += Invalid_fitness2
let int64_to_bytes i =
let b = MBytes.create 8 in
MBytes.set_int64 b 0 i ; b
let int64_of_bytes b =
if Compare.Int.(MBytes.length b <> 8) then fail Invalid_fitness2
else return (MBytes.get_int64 b 0)
let from_int64 fitness = [int64_to_bytes fitness]
let to_int64 = function
| [fitness] ->
int64_of_bytes fitness
| [] ->
return 0L
| _ ->
fail Invalid_fitness
let get {fitness} = fitness
end
let begin_application ~chain_id:_ ~predecessor_context:context
~predecessor_timestamp:_ ~predecessor_fitness:_ (raw_block : block_header)
=
Fitness.to_int64 raw_block.shell.fitness
>>=? fun fitness -> return {context; fitness}
let begin_partial_application ~chain_id ~ancestor_context
~predecessor_timestamp ~predecessor_fitness raw_block =
begin_application
~chain_id
~predecessor_context:ancestor_context
~predecessor_timestamp
~predecessor_fitness
raw_block
let begin_construction ~chain_id:_ ~predecessor_context:context
~predecessor_timestamp:_ ~predecessor_level:_
~predecessor_fitness:pred_fitness ~predecessor:_ ~timestamp:_
?protocol_data:_ () =
Fitness.to_int64 pred_fitness
>>=? fun pred_fitness ->
let fitness = Int64.succ pred_fitness in
return {context; fitness}
let apply_operation ctxt _ = return (ctxt, ())
let finalize_block ctxt =
let fitness = Fitness.get ctxt in
let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
let fitness = Fitness.from_int64 fitness in
return
( {
Updater.message;
context = ctxt.context;
fitness;
max_operations_ttl = 0;
last_allowed_fork_level = 0l;
},
() )
let rpc_services = RPC_directory.empty
let init ctxt block_header =
let fitness = block_header.Block_header.fitness in
let message = None in
return
{
Updater.message;
context = ctxt;
fitness;
max_operations_ttl = 0;
last_allowed_fork_level = 0l;
}
src/bin_client/test/proto_test_injection/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition block_header_data := Tezos_base__TzPervasives.MBytes.t.
Record block_header := {
shell : Tezos_base__TzPervasives.Block_header.shell_header;
protocol_data : block_header_data }.
Definition block_header_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
obj1 (req None None "random_data" % string Variable.bytes).
Definition block_header_metadata := unit.
Definition block_header_metadata_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.
Definition operation_data := unit.
Definition operation_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.
Definition operation_receipt := unit.
Definition operation_receipt_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.
Definition operation_data_and_receipt_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding (unit * unit) :=
Data_encoding.conv
(fun function_parameter =>
let '(tt, tt) := function_parameter in
tt)
(fun function_parameter =>
let 'tt := function_parameter in
(tt, tt)) None Data_encoding.unit.
Record operation := {
shell : Tezos_base__TzPervasives.Operation.shell_header;
protocol_data : operation_data }.
Definition max_block_length : Z := 42.
Definition max_operation_data_length : Z := 42.
Definition validation_passes {A : Type} : list A := [].
Definition acceptable_passes {A B : Type} (_op : A) : list B := [].
Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
0.
Definition current_context {A B : Type} (function_parameter : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
let '_ := function_parameter in
_return op_startypeminuserrorstar.
Module Fitness.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition int64_to_bytes (i : int64) : Tezos_base__TzPervasives.MBytes.t :=
let b := MBytes.create 8 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := MBytes.set_int64 b 0 i in
b.
Definition int64_of_bytes (b : Tezos_base__TzPervasives.MBytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult int64) :=
if op_ltgt (MBytes.length b) 8 then
fail Tezos_base__TzPervasives.Invalid_fitness2
else
_return (MBytes.get_int64 b 0).
Definition from_int64 (fitness : int64)
: list Tezos_base__TzPervasives.MBytes.t := cons (int64_to_bytes fitness) [].
Definition to_int64
(function_parameter : list Tezos_base__TzPervasives.MBytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult int64) :=
match function_parameter with
| cons fitness [] => int64_of_bytes fitness
| [] =>
_return
(* ❌ Constant of type int64 is converted to int *)
0
| _ => fail Tezos_base__TzPervasives.Invalid_fitness
end.
Definition get {A B : Type} (function_parameter : A) : B :=
let '_ := function_parameter in
op_startypeminuserrorstar.
End Fitness.
Definition begin_application {A B C D E : Type} (function_parameter : A)
: B -> C -> D -> block_header -> Lwt.t (Tezos_base__TzPervasives.tzresult E) :=
let '_ := function_parameter in
fun context =>
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun raw_block =>
op_gtgteqquestion (Fitness.to_int64 (fitness (shell raw_block)))
(fun fitness => _return op_startypeminuserrorstar).
Definition begin_partial_application {A B C D E : Type}
(chain_id : A) (ancestor_context : B) (predecessor_timestamp : C)
(predecessor_fitness : D) (raw_block : block_header)
: Lwt.t (Tezos_base__TzPervasives.tzresult E) :=
begin_application chain_id ancestor_context predecessor_timestamp
predecessor_fitness raw_block.
Definition begin_construction {A B C D E F G H : Type} (function_parameter : A)
: B ->
C ->
D ->
(list Tezos_base__TzPervasives.MBytes.t) ->
E ->
F ->
(option G) -> unit -> Lwt.t (Tezos_base__TzPervasives.tzresult H) :=
let '_ := function_parameter in
fun context =>
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun pred_fitness =>
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Fitness.to_int64 pred_fitness)
(fun pred_fitness =>
let fitness := Int64.succ pred_fitness in
_return op_startypeminuserrorstar).
Definition apply_operation {A B : Type} (ctxt : A) (function_parameter : B)
: Lwt.t (Tezos_base__TzPervasives.tzresult (A * unit)) :=
let '_ := function_parameter in
_return (ctxt, tt).
Definition finalize_block {A B : Type} (ctxt : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult (B * unit)) :=
let fitness := Fitness.get ctxt in
let message :=
Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "fitness <- " % string
(CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "fitness <- %Ld" % string)
fitness) in
let fitness := Fitness.from_int64 fitness in
_return (op_startypeminuserrorstar, tt).
Definition rpc_services {A : Type}
: Tezos_base__TzPervasives.RPC_directory.directory A := RPC_directory.empty.
Definition init {A B : Type}
(ctxt : A) (block_header : Tezos_base__TzPervasives.Block_header.shell_header)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
let fitness := Block_header.fitness block_header in
let message := None in
_return op_startypeminuserrorstar.
src/bin_codec/codec.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let commands = Commands.commands ()
let home = try Sys.getenv "HOME" with Not_found -> "/tmp"
let default_base_dir = Filename.concat home ".tezos-client"
let base_dir_arg =
let open Clic in
arg
~long:"base-dir"
~short:'d'
~placeholder:"path"
~doc:
( "data directory\n\
The directory where the Tezos codec will output logs.\n\
By default: '" ^ default_base_dir ^ "'." )
(parameter (fun _ctxt x -> return x))
let global_options = Clic.args1 base_dir_arg
let parse_config_args argv =
(* The context used during argument parsing. We switch to a real context
that is created based on some of the parsed arguments. *)
let ctxt = Client_context.null_printer in
Clic.parse_global_options global_options ctxt argv
>>=? fun (base_dir, argv) ->
( match base_dir with
| None ->
let base_dir = default_base_dir in
( if Sys.file_exists base_dir then Lwt.return_unit
else Lwt_utils_unix.create_dir base_dir )
>>= fun () -> return base_dir
| Some dir ->
if not (Sys.file_exists dir) then
failwith
"Specified -base-dir does not exist. Please create the directory \
and try again."
else if not (Sys.is_directory dir) then
failwith "Specified -base-dir must be a directory"
else return dir )
>>=? fun base_dir -> return (base_dir, argv)
(* Main (lwt) entry *)
let main commands =
let executable_name = Filename.basename Sys.executable_name in
let run () =
let (argv, autocomplete) =
(* for shell aliases *)
let rec move_autocomplete_token_upfront acc = function
| "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args ->
let args = List.rev acc @ args in
(args, Some (prev_arg, cur_arg, script))
| x :: rest ->
move_autocomplete_token_upfront (x :: acc) rest
| [] ->
(List.rev acc, None)
in
match Array.to_list Sys.argv with
| _ :: args ->
move_autocomplete_token_upfront [] args
| [] ->
([], None)
in
Random.self_init () ;
ignore
Clic.(
setup_formatter
Format.std_formatter
(if Unix.isatty Unix.stdout then Ansi else Plain)
Short) ;
ignore
Clic.(
setup_formatter
Format.err_formatter
(if Unix.isatty Unix.stderr then Ansi else Plain)
Short) ;
Internal_event_unix.init ()
>>= fun () ->
parse_config_args argv
>>=? fun (base_dir, argv) ->
let ctxt = new Client_context_unix.unix_logger ~base_dir in
let commands =
Clic.add_manual
~executable_name
~global_options
(if Unix.isatty Unix.stdout then Clic.Ansi else Clic.Plain)
Format.std_formatter
commands
in
match autocomplete with
| Some (prev_arg, cur_arg, script) ->
Clic.autocompletion
~script
~cur_arg
~prev_arg
~args:argv
~global_options
commands
ctxt
>>=? fun completions ->
List.iter print_endline completions ;
return_unit
| None ->
Clic.dispatch commands ctxt argv
in
Pervasives.exit
(Lwt_main.run
( Lwt.catch run (function
| Failure msg ->
failwith "%s" msg
| exn ->
failwith "%s" (Printexc.to_string exn))
>>= (function
| Ok () ->
Lwt.return 0
| Error [Clic.Help command] ->
Clic.usage
Format.std_formatter
~executable_name
~global_options
(match command with None -> [] | Some c -> [c]) ;
Lwt.return 0
| Error errs ->
Clic.pp_cli_errors
Format.err_formatter
~executable_name
~global_options
~default:Error_monad.pp
errs ;
Lwt.return 1)
>>= fun retcode ->
Format.pp_print_flush Format.err_formatter () ;
Format.pp_print_flush Format.std_formatter () ;
Lwt.return retcode ))
let () = main commands
src/bin_codec/codec.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition commands
: list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer) :=
Commands.commands tt.
Definition home : string :=
(* ❌ Try-with are not handled *)
try (Sys.getenv "HOME" % string).
Definition default_base_dir : string :=
Filename.concat home ".tezos-client" % string.
Definition base_dir_arg
: Tezos_clic.Clic.arg (option string) Tezos_client_base.Client_context.printer :=
arg
(String.append
"data directory
The directory where the Tezos codec will output logs.
By default: '"
% string (String.append default_base_dir "'." % string))
(Some "d" % char) "base-dir" % string "path" % string
(parameter None (fun _ctxt => fun x => _return x)).
Definition global_options
: Tezos_clic.Clic.options (option string)
Tezos_client_base.Client_context.printer := Clic.args1 base_dir_arg.
Definition parse_config_args (argv : list string)
: Lwt.t (Tezos_base__TzPervasives.tzresult (string * (list string))) :=
let ctxt := Client_context.null_printer in
op_gtgteqquestion (Clic.parse_global_options global_options ctxt argv)
(fun function_parameter =>
let '(base_dir, argv) := function_parameter in
op_gtgteqquestion
match base_dir with
| None =>
let base_dir := default_base_dir in
op_gtgteq
(if Sys.file_exists base_dir then
Lwt.return_unit
else
Lwt_utils_unix.create_dir None base_dir)
(fun function_parameter =>
let 'tt := function_parameter in
_return base_dir)
| Some dir =>
if negb (Sys.file_exists dir) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Specified -base-dir does not exist. Please create the directory and try again."
% string CamlinternalFormatBasics.End_of_format)
"Specified -base-dir does not exist. Please create the directory and try again."
% string)
else
if negb (Sys.is_directory dir) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Specified -base-dir must be a directory" % string
CamlinternalFormatBasics.End_of_format)
"Specified -base-dir must be a directory" % string)
else
_return dir
end (fun base_dir => _return (base_dir, argv))).
Definition main {A : Type}
(commands :
list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer))
: A :=
let executable_name := Filename.basename Sys.executable_name in
let run (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
let '(argv, autocomplete) :=
let fix move_autocomplete_token_upfront
(acc : list string) (function_parameter : list string)
: (list string) * (option (string * string * string)) :=
match function_parameter with
|
cons "bash_autocomplete" % string
(cons prev_arg (cons cur_arg (cons script args))) =>
let args := OCaml.Stdlib.app (List.rev acc) args in
(args, (Some (prev_arg, cur_arg, script)))
| cons x rest => move_autocomplete_token_upfront (cons x acc) rest
| [] => ((List.rev acc), None)
end in
match Array.to_list Sys.argv with
| cons _ args => move_autocomplete_token_upfront [] args
| [] => ([], None)
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Random.self_init tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter Format.std_formatter
(if Unix.isatty Unix.stdout then
Tezos_clic.Clic.Ansi
else
Tezos_clic.Clic.Plain) Tezos_clic.Clic.Short) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter Format.err_formatter
(if Unix.isatty Unix.stderr then
Tezos_clic.Clic.Ansi
else
Tezos_clic.Clic.Plain) Tezos_clic.Clic.Short) in
op_gtgteq (Internal_event_unix.init None None tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (parse_config_args argv)
(fun function_parameter =>
let '(base_dir, argv) := function_parameter in
let ctxt :=
(* ❌ Creation of new objects is not handled *)
new base_dir in
let commands :=
Clic.add_manual executable_name global_options
(if Unix.isatty Unix.stdout then
Tezos_clic.Clic.Ansi
else
Tezos_clic.Clic.Plain) Format.std_formatter commands in
match autocomplete with
| Some (prev_arg, cur_arg, script) =>
op_gtgteqquestion
(Clic.autocompletion script cur_arg prev_arg argv global_options
commands ctxt)
(fun completions =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter OCaml.Stdlib.print_endline completions in
return_unit)
| None => Clic.dispatch commands ctxt argv
end)) in
Pervasives.exit
(Lwt_main.run
(op_gtgteq
(op_gtgteq
(Lwt.catch run
(fun function_parameter =>
match function_parameter with
| OCaml.Failure msg =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) msg
| exn =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Printexc.to_string exn)
end))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt._return 0
|
Stdlib.Error
(cons (Tezos_error_monad.Error_monad.Help command) []) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Clic.usage Format.std_formatter executable_name global_options
match command with
| None => []
| Some c => cons c []
end in
Lwt._return 0
| Stdlib.Error errs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Clic.pp_cli_errors Format.err_formatter executable_name
global_options Error_monad.pp errs in
Lwt._return 1
end))
(fun retcode =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_flush Format.err_formatter tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_flush Format.std_formatter tt in
Lwt._return retcode))).
src/bin_codec/commands.ml 69 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
open Clic
let group = {name = "encoding"; title = "Commands to handle encodings"}
let id_parameter =
parameter (fun (cctxt : #Client_context.printer) id ->
match Data_encoding.Registration.find id with
| Some record ->
return record
| None ->
cctxt#error "Unkown encoding id: %s" id)
let json_parameter =
parameter (fun (cctxt : #Client_context.printer) file_or_data ->
Lwt_unix.file_exists file_or_data
>>= (function
| true ->
Tezos_stdlib_unix.Lwt_utils_unix.read_file file_or_data
| false ->
Lwt.return file_or_data)
>>= fun data ->
match Json.from_string data with
| Ok json ->
return json
| Error err ->
cctxt#error "%s" err)
let bytes_parameter = parameter (fun _ hex -> return (Hex.to_bytes (`Hex hex)))
let commands () =
[ command
~group
~desc:"List the registered encoding in Tezos."
no_options
(fixed ["list"; "encodings"])
(fun () (cctxt : #Client_context.printer) ->
let bindings =
Data_encoding.Registration.list ()
|> List.map (fun (id, elem) ->
(id, Data_encoding.Registration.description elem))
in
cctxt#message
"@[<v>%a@]@."
(Format.pp_print_list
~pp_sep:Format.pp_print_cut
(fun ppf (id, desc) ->
let desc =
Option.unopt ~default:"No description available." desc
in
Format.fprintf
ppf
"@[<v 2>%s:@ @[%a@]@]"
id
Format.pp_print_text
desc))
bindings
>>= fun () -> return_unit);
command
~group
~desc:"Dump a json description of all registered encodings."
( args1
@@ switch
~doc:
"Output json descriptions without extraneous whitespace characters"
~long:"compact"
() )
(fixed ["dump"; "encodings"])
(fun minify (cctxt : #Client_context.printer) ->
cctxt#message
"%s"
(Json.to_string
~minify
(`A
( Registration.list ()
|> List.map (fun (id, enc) ->
`O
[ ("id", `String id);
( "json",
Json.construct
Json.schema_encoding
(Registration.json_schema enc) );
( "binary",
Json.construct
Binary_schema.encoding
(Registration.binary_schema enc) ) ]) )))
>>= fun () -> return_unit);
(* JSON -> Binary *)
command
~group
~desc:
"Encode the given JSON data into binary using the provided encoding \
identifier."
no_options
( prefix "encode"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefix "from"
@@ param ~name:"json" ~desc:"JSON file or data" json_parameter
@@ stop )
(fun () registered_encoding json (cctxt : #Client_context.printer) ->
match
Data_encoding.Registration.bytes_of_json registered_encoding json
with
| exception exn ->
cctxt#error "%a" (fun ppf exn -> Json.print_error ppf exn) exn
| None ->
cctxt#error
"Impossible to the JSON convert to binary.@,\
This error should not happen."
| Some bytes ->
cctxt#message "%a" Hex.pp (Hex.of_bytes bytes)
>>= fun () -> return_unit);
(* Binary -> JSON *)
command
~group
~desc:
"Decode the binary encoded data into JSON using the provided encoding \
identifier."
no_options
( prefix "decode"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefix "from"
@@ param ~name:"hex" ~desc:"Binary encoded data" bytes_parameter
@@ stop )
(fun () registered_encoding bytes (cctxt : #Client_context.printer) ->
match
Data_encoding.Registration.json_of_bytes registered_encoding bytes
with
| None ->
cctxt#error "Cannot parse the binary with the given encoding"
| Some bytes ->
cctxt#message "%a" Json.pp bytes >>= fun () -> return_unit);
command
~group
~desc:
"Display the binary encoded data using the provided encoding \
identifier."
no_options
( prefix "display"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefixes ["from"; "binary"]
@@ param ~name:"hex" ~desc:"Binary encoded data" bytes_parameter
@@ stop )
(fun () registered_encoding bytes (cctxt : #Client_context.printer) ->
let pp_bytes fmt bytes =
Data_encoding.Registration.binary_pretty_printer
registered_encoding
fmt
bytes
in
cctxt#message "%a" pp_bytes bytes >>= fun () -> return_unit);
command
~group
~desc:
"Display the JSON encoded data using the provided encoding identifier."
no_options
( prefix "display"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefixes ["from"; "json"]
@@ param ~name:"json" ~desc:"JSON file or data" json_parameter
@@ stop )
(fun () registered_encoding json (cctxt : #Client_context.printer) ->
let pp_json fmt json =
Data_encoding.Registration.json_pretty_printer
registered_encoding
fmt
json
in
cctxt#message "%a" pp_json json >>= fun () -> return_unit);
command
~group
~desc:
"Describe the binary schema associated to the provided encoding \
identifier."
no_options
( prefix "describe"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefixes ["binary"; "schema"]
@@ stop )
(fun () registered_encoding (cctxt : #Client_context.printer) ->
let schema =
Data_encoding.Registration.binary_schema registered_encoding
in
cctxt#message "%a" Binary_schema.pp schema >>= fun () -> return_unit);
command
~group
~desc:
"Describe the JSON schema associated to the provided encoding \
identifier."
no_options
( prefix "describe"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefixes ["json"; "schema"]
@@ stop )
(fun () registered_encoding cctxt ->
let schema =
Data_encoding.Registration.json_schema registered_encoding
in
cctxt#message "%a" Json_schema.pp schema >>= fun () -> return_unit) ]
src/bin_codec/commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Import Clic.
Definition group : Tezos_clic.Clic.group :=
{| name := "encoding" % string;
title := "Commands to handle encodings" % string |}.
Definition id_parameter {C a b : Type}
: Tezos_clic.Clic.parameter
Tezos_base__TzPervasives.Data_encoding.Registration.t
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) :=
parameter None
(fun cctxt =>
fun id =>
match Data_encoding.Registration.find id with
| Some record => _return record
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unkown encoding id: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Unkown encoding id: %s" % string) id
end).
Definition json_parameter {C a b : Type}
: Tezos_clic.Clic.parameter Tezos_data_encoding.Json.json
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) :=
parameter None
(fun cctxt =>
fun file_or_data =>
op_gtgteq
(op_gtgteq (Lwt_unix.file_exists file_or_data)
(fun function_parameter =>
match function_parameter with
| true => Tezos_stdlib_unix.Lwt_utils_unix.read_file file_or_data
| false => Lwt._return file_or_data
end))
(fun data =>
match Json.from_string data with
| Stdlib.Ok json => _return json
| Stdlib.Error err =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) err
end)).
Definition bytes_parameter {C a b : Type}
: Tezos_clic.Clic.parameter string
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) :=
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun hex =>
_return
(Hex.to_bytes
(* ❌ Variants not supported *)
variant)).
Definition commands {C a b : Type} (function_parameter : unit)
: list
(Tezos_clic.Clic.command
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C)) :=
let 'tt := function_parameter in
cons
(command (Some group) "List the registered encoding in Tezos." % string
no_options (fixed (cons "list" % string (cons "encodings" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
let bindings :=
OCaml.Stdlib.reverse_apply (Data_encoding.Registration.list tt)
(List.map
(fun function_parameter =>
let '(id, elem) := function_parameter in
(id, (Data_encoding.Registration.description elem)))) in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v>" % string
CamlinternalFormatBasics.End_of_format) "<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"@[<v>%a@]@." % string)
(Format.pp_print_list (Some Format.pp_print_cut)
(fun ppf =>
fun function_parameter =>
let '(id, desc) := function_parameter in
let desc :=
Option.unopt "No description available." % string desc in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1
0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 2>%s:@ @[%a@]@]" % string) id Format.pp_print_text
desc)) bindings)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Dump a json description of all registered encodings." % string
(apply args1
(switch
"Output json descriptions without extraneous whitespace characters"
% string None "compact" % string tt))
(fixed (cons "dump" % string (cons "encodings" % string [])))
(fun minify =>
fun cctxt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Json.to_string None (Some minify)
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Encode the given JSON data into binary using the provided encoding identifier."
% string no_options
(apply (prefix "encode" % string)
(apply
(param "id" % string "Encoding identifier" % string id_parameter)
(apply (prefix "from" % string)
(apply
(param "json" % string "JSON file or data" % string
json_parameter) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun json =>
fun cctxt =>
match
Data_encoding.Registration.bytes_of_json registered_encoding
json with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Impossible to the JSON convert to binary." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"This error should not happen." % string
CamlinternalFormatBasics.End_of_format)))
"Impossible to the JSON convert to binary.@,This error should not happen."
% string)
| Some bytes =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Hex.pp (Hex.of_bytes None string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
(cons
(command (Some group)
"Decode the binary encoded data into JSON using the provided encoding identifier."
% string no_options
(apply (prefix "decode" % string)
(apply
(param "id" % string "Encoding identifier" % string id_parameter)
(apply (prefix "from" % string)
(apply
(param "hex" % string "Binary encoded data" % string
bytes_parameter) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun bytes =>
fun cctxt =>
match
Data_encoding.Registration.json_of_bytes
registered_encoding string with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot parse the binary with the given encoding" %
string CamlinternalFormatBasics.End_of_format)
"Cannot parse the binary with the given encoding" %
string)
| Some bytes =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Json.pp string)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
(cons
(command (Some group)
"Display the binary encoded data using the provided encoding identifier."
% string no_options
(apply (prefix "display" % string)
(apply
(param "id" % string "Encoding identifier" % string
id_parameter)
(apply
(prefixes (cons "from" % string (cons "binary" % string [])))
(apply
(param "hex" % string "Binary encoded data" % string
bytes_parameter) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun bytes =>
fun cctxt =>
let pp_bytes
(fmt : Stdlib.Format.formatter) (bytes : Stdlib.Bytes.t)
: unit :=
Data_encoding.Registration.binary_pretty_printer
registered_encoding fmt string in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) pp_bytes string)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Display the JSON encoded data using the provided encoding identifier."
% string no_options
(apply (prefix "display" % string)
(apply
(param "id" % string "Encoding identifier" % string
id_parameter)
(apply
(prefixes (cons "from" % string (cons "json" % string [])))
(apply
(param "json" % string "JSON file or data" % string
json_parameter) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun json =>
fun cctxt =>
let pp_json
(fmt : Stdlib.Format.formatter) (json :
Tezos_data_encoding.Json.t) : unit :=
Data_encoding.Registration.json_pretty_printer
registered_encoding fmt json in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) pp_json json)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Describe the binary schema associated to the provided encoding identifier."
% string no_options
(apply (prefix "describe" % string)
(apply
(param "id" % string "Encoding identifier" % string
id_parameter)
(apply
(prefixes
(cons "binary" % string (cons "schema" % string [])))
stop)))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun cctxt =>
let schema :=
Data_encoding.Registration.binary_schema
registered_encoding in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Binary_schema.pp schema)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Describe the JSON schema associated to the provided encoding identifier."
% string no_options
(apply (prefix "describe" % string)
(apply
(param "id" % string "Encoding identifier" % string
id_parameter)
(apply
(prefixes
(cons "json" % string (cons "schema" % string [])))
stop)))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun cctxt =>
let schema :=
Data_encoding.Registration.json_schema
registered_encoding in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Json_schema.pp schema)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) []))))))).
src/bin_node/genesis_chain.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018-2019 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let genesis : State.Chain.genesis =
{
time = Time.Protocol.of_notation_exn "2018-06-30T16:07:32Z";
block =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisf79b5d1CoW2";
protocol =
Protocol_hash.of_b58check_exn
"ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im";
}
src/bin_node/genesis_chain.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition genesis : Tezos_shell.State.Chain.genesis :=
{| time := Time.Protocol.of_notation_exn "2018-06-30T16:07:32Z" % string;
block :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisf79b5d1CoW2" % string;
protocol :=
Protocol_hash.of_b58check_exn
"ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" % string |}.
src/bin_node/main.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
let log s = Node_logging.fatal_error "%s" s in
Lwt_exit.exit_on ~log Sys.sigint ;
Lwt_exit.exit_on ~log Sys.sigterm
let () =
if Filename.basename Sys.argv.(0) = Updater.compiler_name then (
try
Tezos_protocol_compiler.Compiler.main
Tezos_protocol_compiler_native.Native.driver ;
Pervasives.exit 0
with exn ->
Format.eprintf "%a\n%!" Opterrors.report_error exn ;
Pervasives.exit 1 )
let () =
if Filename.basename Sys.argv.(0) = "tezos-validator" then (
try Pervasives.exit (Lwt_main.run @@ Validator.main ())
with exn ->
Format.eprintf "%a\n%!" Opterrors.report_error exn ;
Pervasives.exit 1 )
let term =
let open Cmdliner.Term in
ret (const (`Help (`Pager, None)))
let description =
[ `S "DESCRIPTION";
`P "Entry point for initializing, configuring and running a Tezos node.";
`P Node_identity_command.Manpage.command_description;
`P Node_run_command.Manpage.command_description;
`P Node_config_command.Manpage.command_description;
`P Node_snapshot_command.Manpage.command_description ]
let man = description @ Node_run_command.Manpage.examples
let info =
let version =
Tezos_version.Current_git_info.abbreviated_commit_hash ^ " ("
^ Tezos_version.Current_git_info.committer_date ^ ")"
in
Cmdliner.Term.info ~doc:"The Tezos node" ~man ~version "tezos-node"
let commands =
[ Node_run_command.cmd;
Node_config_command.cmd;
Node_identity_command.cmd;
Node_snapshot_command.cmd ]
let () =
Random.self_init () ;
match Cmdliner.Term.eval_choice (term, info) commands with
| `Error _ ->
exit 1
| `Help ->
exit 0
| `Version ->
exit 1
| `Ok () ->
exit 0
src/bin_node/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition term {A : Type} : Cmdliner.Term.t A :=
ret
(const
(* ❌ Variants not supported *)
variant).
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []))))).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description Node_run_command.Manpage.examples.
Definition info : Cmdliner.Term.info :=
let version :=
String.append Tezos_version.Current_git_info.abbreviated_commit_hash
(String.append " (" % string
(String.append Tezos_version.Current_git_info.committer_date
")" % string)) in
Cmdliner.Term.info None (Some man) None None None None
(Some "The Tezos node" % string) (Some version) "tezos-node" % string.
Definition commands : list ((Cmdliner.Term.t unit) * Cmdliner.Term.info) :=
cons Node_run_command.cmd
(cons Node_config_command.cmd
(cons Node_identity_command.cmd (cons Node_snapshot_command.cmd []))).
src/bin_node/node_config_command.ml 24 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Commands *)
let show (args : Node_shared_arg.t) =
if not @@ Sys.file_exists args.config_file then
Format.eprintf
"\n\
Warning: no config file at %s,\n\
\ displaying the default configuration.\n\
@."
args.config_file ;
Node_shared_arg.read_and_patch_config_file args
>>=? fun cfg ->
Node_config_file.check cfg
>>= fun () ->
print_endline @@ Node_config_file.to_string cfg ;
return_unit
let reset (args : Node_shared_arg.t) =
if Sys.file_exists args.config_file then
Format.eprintf
"Ignoring previous configuration file: %s.@."
args.config_file ;
Node_shared_arg.read_and_patch_config_file args
>>=? fun cfg ->
Node_config_file.check cfg
>>= fun () -> Node_config_file.write args.config_file cfg
let init (args : Node_shared_arg.t) =
if Sys.file_exists args.config_file then
failwith "Pre-existing config file at %s, use `reset`." args.config_file
else
Node_shared_arg.read_and_patch_config_file args
>>=? fun cfg ->
Node_config_file.check cfg
>>= fun () -> Node_config_file.write args.config_file cfg
let update (args : Node_shared_arg.t) =
if not (Sys.file_exists args.config_file) then
failwith
"Missing configuration file at %s. Use `%s config init [options]` to \
generate a new file"
args.config_file
Sys.argv.(0)
else
Node_shared_arg.read_and_patch_config_file args
>>=? fun cfg ->
Node_config_file.check cfg
>>= fun () -> Node_config_file.write args.config_file cfg
(** Main *)
module Term = struct
type subcommand = Show | Reset | Init | Update
let process subcommand args =
let res =
match subcommand with
| Show ->
show args
| Reset ->
reset args
| Init ->
init args
| Update ->
update args
in
match Lwt_main.run res with
| Ok () ->
`Ok ()
| Error err ->
`Error (false, Format.asprintf "%a" pp_print_error err)
let subcommand_arg =
let parser = function
| "show" ->
`Ok Show
| "reset" ->
`Ok Reset
| "init" ->
`Ok Init
| "update" ->
`Ok Update
| s ->
`Error ("invalid argument: " ^ s)
and printer ppf = function
| Show ->
Format.fprintf ppf "show"
| Reset ->
Format.fprintf ppf "reset"
| Init ->
Format.fprintf ppf "init"
| Update ->
Format.fprintf ppf "update"
in
let open Cmdliner.Arg in
let doc =
"Operation to perform. Possible values: $(b,show), $(b,reset), \
$(b,init), $(b,update)."
in
value & pos 0 (parser, printer) Show & info [] ~docv:"OPERATION" ~doc
let term =
let open Cmdliner.Term in
ret (const process $ subcommand_arg $ Node_shared_arg.Term.args)
end
module Manpage = struct
let command_description =
"The $(b,config) command is meant to inspect and amend the configuration \
of the Tezos node. This command is complementary to manually editing the \
tezos node configuration file. Its arguments are a subset of the \
$(i,run) command ones."
let description =
[ `S "DESCRIPTION";
`P (command_description ^ " Several operations are possible: ");
`P
"$(b,show) reads, parses and displays Tezos current config file. Use \
this command to see exactly what config file will be used by Tezos. \
If additional command-line arguments are provided, the displayed \
configuration will be amended accordingly. This is the default \
operation.";
`P
"$(b,reset) will overwrite the current configuration file with a \
factory default one. If additional command-line arguments are \
provided, they will amend the generated file. It assumes that a \
configuration file already exists and will abort otherwise.";
`P
"$(b,init) is like reset but assumes that no configuration file is \
present and will abort otherwise.";
`P
"$(b,update) is the main option to edit the configuration file of \
Tezos. It will parse command line arguments and add or replace \
corresponding entries in the Tezos configuration file." ]
let options =
let schema = Data_encoding.Json.schema Node_config_file.encoding in
let schema = Format.asprintf "@[%a@]" Json_schema.pp schema in
let schema = String.concat "\\$" (String.split '$' schema) in
[`S "OPTIONS"; `P "All options available in the config file"; `Pre schema]
let man =
description @ Node_shared_arg.Manpage.args @ options
@ Node_shared_arg.Manpage.bugs
let info = Cmdliner.Term.info ~doc:"Manage node configuration" ~man "config"
end
let cmd = (Term.term, Manpage.info)
src/bin_node/node_config_command.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition show (args : Node_shared_arg.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if apply negb (Sys.file_exists (config_file args)) then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"
Warning: no config file at " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
",
displaying the default configuration.
" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"
Warning: no config file at %s,
displaying the default configuration.
@."
% string) (config_file args)
else
tt in
op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
(fun cfg =>
op_gtgteq (Node_config_file.check cfg)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply OCaml.Stdlib.print_endline (Node_config_file.to_string cfg) in
return_unit)).
Definition reset (args : Node_shared_arg.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if Sys.file_exists (config_file args) then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ignoring previous configuration file: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Ignoring previous configuration file: %s.@." % string)
(config_file args)
else
tt in
op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
(fun cfg =>
op_gtgteq (Node_config_file.check cfg)
(fun function_parameter =>
let 'tt := function_parameter in
Node_config_file.write (config_file args) cfg)).
Definition init (args : Node_shared_arg.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if Sys.file_exists (config_file args) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Pre-existing config file at " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ", use `reset`." % string
CamlinternalFormatBasics.End_of_format)))
"Pre-existing config file at %s, use `reset`." % string)
(config_file args)
else
op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
(fun cfg =>
op_gtgteq (Node_config_file.check cfg)
(fun function_parameter =>
let 'tt := function_parameter in
Node_config_file.write (config_file args) cfg)).
Definition update (args : Node_shared_arg.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if negb (Sys.file_exists (config_file args)) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Missing configuration file at " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ". Use `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" config init [options]` to generate a new file" % string
CamlinternalFormatBasics.End_of_format)))))
"Missing configuration file at %s. Use `%s config init [options]` to generate a new file"
% string) (config_file args) (Array.get Sys.argv 0)
else
op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
(fun cfg =>
op_gtgteq (Node_config_file.check cfg)
(fun function_parameter =>
let 'tt := function_parameter in
Node_config_file.write (config_file args) cfg)).
Module Term.
Inductive subcommand : Type :=
| Show : subcommand
| Reset : subcommand
| Init : subcommand
| Update : subcommand.
Definition process (subcommand : subcommand) (args : Node_shared_arg.t)
: variant :=
let res :=
match subcommand with
| Show => show args
| Reset => reset args
| Init => init args
| Update => update args
end in
match Lwt_main.run res with
| Stdlib.Ok tt =>
(* ❌ Variants not supported *)
variant
| Stdlib.Error err =>
(* ❌ Variants not supported *)
variant
end.
Definition subcommand_arg : Cmdliner.Term.t subcommand :=
let parser (function_parameter : string) : variant :=
match function_parameter with
| "show" % string =>
(* ❌ Variants not supported *)
variant
| "reset" % string =>
(* ❌ Variants not supported *)
variant
| "init" % string =>
(* ❌ Variants not supported *)
variant
| "update" % string =>
(* ❌ Variants not supported *)
variant
| s =>
(* ❌ Variants not supported *)
variant
end
with printer
(ppf : Stdlib.Format.formatter) (function_parameter : subcommand)
: unit :=
match function_parameter with
| Show =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "show" % string
CamlinternalFormatBasics.End_of_format) "show" % string)
| Reset =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "reset" % string
CamlinternalFormatBasics.End_of_format) "reset" % string)
| Init =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "init" % string
CamlinternalFormatBasics.End_of_format) "init" % string)
| Update =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "update" % string
CamlinternalFormatBasics.End_of_format) "update" % string)
end in
let doc :=
"Operation to perform. Possible values: $(b,show), $(b,reset), $(b,init), $(b,update)."
% string in
op_and value
(op_and (pos None 0 (parser, printer) Show)
(info None (Some "OPERATION" % string) (Some doc) None [])).
Definition term : Cmdliner.Term.t unit :=
ret
(op_dollar (op_dollar (const process) subcommand_arg)
Node_shared_arg.Term.args).
End Term.
Module Manpage.
Definition command_description : string :=
"The $(b,config) command is meant to inspect and amend the configuration of the Tezos node. This command is complementary to manually editing the tezos node configuration file. Its arguments are a subset of the $(i,run) command ones."
% string.
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []))))).
Definition options : list variant :=
let schema := Data_encoding.Json.schema None Node_config_file.encoding in
let schema :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[%a@]" % string)
Json_schema.pp schema in
let schema :=
String.concat "\$" % string (String.split "$" % char None None schema) in
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description
(OCaml.Stdlib.app Node_shared_arg.Manpage.args
(OCaml.Stdlib.app options Node_shared_arg.Manpage.bugs)).
Definition info : Cmdliner.Term.info :=
Cmdliner.Term.info None (Some man) None None None None
(Some "Manage node configuration" % string) None "config" % string.
End Manpage.
Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
(Term.term, Manpage.info).
src/bin_node/node_config_file.ml 66 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
[@@@ocaml.warning "-30"]
let ( // ) = Filename.concat
let home = try Sys.getenv "HOME" with Not_found -> "/root"
let default_data_dir = home // ".tezos-node"
let default_rpc_port = 8732
let default_p2p_port = 9732
let default_discovery_port = 10732
type t = {
data_dir : string;
p2p : p2p;
rpc : rpc;
log : Lwt_log_sink_unix.cfg;
internal_events : Internal_event_unix.Configuration.t;
shell : shell;
}
and p2p = {
expected_pow : float;
bootstrap_peers : string list;
listen_addr : string option;
discovery_addr : string option;
private_mode : bool;
limits : P2p.limits;
disable_mempool : bool;
disable_testchain : bool;
greylisting_config : P2p_point_state.Info.greylisting_config;
}
and rpc = {
listen_addrs : string list;
cors_origins : string list;
cors_headers : string list;
tls : tls option;
}
and tls = {cert : string; key : string}
and shell = {
block_validator_limits : Node.block_validator_limits;
prevalidator_limits : Node.prevalidator_limits;
peer_validator_limits : Node.peer_validator_limits;
chain_validator_limits : Node.chain_validator_limits;
history_mode : History_mode.t option;
}
let default_p2p_limits : P2p.limits =
{
connection_timeout = Time.System.Span.of_seconds_exn 10.;
authentication_timeout = Time.System.Span.of_seconds_exn 5.;
greylist_timeout = Time.System.Span.of_seconds_exn 86400. (* one day *);
maintenance_idle_time =
Time.System.Span.of_seconds_exn 120. (* two minutes *);
min_connections = 10;
expected_connections = 50;
max_connections = 100;
backlog = 20;
max_incoming_connections = 20;
max_download_speed = None;
max_upload_speed = None;
read_buffer_size = 1 lsl 14;
read_queue_size = None;
write_queue_size = None;
incoming_app_message_queue_size = None;
incoming_message_queue_size = None;
outgoing_message_queue_size = None;
known_points_history_size = 500;
known_peer_ids_history_size = 500;
max_known_points = Some (400, 300);
max_known_peer_ids = Some (400, 300);
swap_linger = Time.System.Span.of_seconds_exn 30.;
binary_chunks_size = None;
}
let default_p2p =
{
expected_pow = 26.;
bootstrap_peers = [];
listen_addr = Some ("[::]:" ^ string_of_int default_p2p_port);
discovery_addr = None;
private_mode = false;
limits = default_p2p_limits;
disable_mempool = false;
disable_testchain = false;
greylisting_config = P2p_point_state.Info.default_greylisting_config;
}
let default_rpc =
{listen_addrs = []; cors_origins = []; cors_headers = []; tls = None}
let default_shell =
{
block_validator_limits = Node.default_block_validator_limits;
prevalidator_limits = Node.default_prevalidator_limits;
peer_validator_limits = Node.default_peer_validator_limits;
chain_validator_limits = Node.default_chain_validator_limits;
history_mode = None;
}
let default_config =
{
data_dir = default_data_dir;
p2p = default_p2p;
rpc = default_rpc;
log = Lwt_log_sink_unix.default_cfg;
internal_events = Internal_event_unix.Configuration.default;
shell = default_shell;
}
let limit : P2p.limits Data_encoding.t =
let open Data_encoding in
conv
(fun { P2p.connection_timeout;
authentication_timeout;
greylist_timeout;
maintenance_idle_time;
min_connections;
expected_connections;
max_connections;
backlog;
max_incoming_connections;
max_download_speed;
max_upload_speed;
read_buffer_size;
read_queue_size;
write_queue_size;
incoming_app_message_queue_size;
incoming_message_queue_size;
outgoing_message_queue_size;
known_points_history_size;
known_peer_ids_history_size;
max_known_points;
max_known_peer_ids;
swap_linger;
binary_chunks_size } ->
( ( ( connection_timeout,
authentication_timeout,
min_connections,
expected_connections,
max_connections,
backlog,
max_incoming_connections,
max_download_speed,
max_upload_speed,
swap_linger ),
( binary_chunks_size,
read_buffer_size,
read_queue_size,
write_queue_size,
incoming_app_message_queue_size,
incoming_message_queue_size,
outgoing_message_queue_size,
known_points_history_size,
known_peer_ids_history_size,
max_known_points ) ),
(max_known_peer_ids, greylist_timeout, maintenance_idle_time) ))
(fun ( ( ( connection_timeout,
authentication_timeout,
min_connections,
expected_connections,
max_connections,
backlog,
max_incoming_connections,
max_download_speed,
max_upload_speed,
swap_linger ),
( binary_chunks_size,
read_buffer_size,
read_queue_size,
write_queue_size,
incoming_app_message_queue_size,
incoming_message_queue_size,
outgoing_message_queue_size,
known_points_history_size,
known_peer_ids_history_size,
max_known_points ) ),
(max_known_peer_ids, greylist_timeout, maintenance_idle_time) ) ->
{
connection_timeout;
authentication_timeout;
greylist_timeout;
maintenance_idle_time;
min_connections;
expected_connections;
max_connections;
backlog;
max_incoming_connections;
max_download_speed;
max_upload_speed;
read_buffer_size;
read_queue_size;
write_queue_size;
incoming_app_message_queue_size;
incoming_message_queue_size;
outgoing_message_queue_size;
known_points_history_size;
known_peer_ids_history_size;
max_known_points;
max_known_peer_ids;
swap_linger;
binary_chunks_size;
})
(merge_objs
(merge_objs
(obj10
(dft
"connection-timeout"
~description:
"Delay acceptable when initiating a connection to a new \
peer, in seconds."
Time.System.Span.encoding
default_p2p_limits.authentication_timeout)
(dft
"authentication-timeout"
~description:
"Delay granted to a peer to perform authentication, in \
seconds."
Time.System.Span.encoding
default_p2p_limits.authentication_timeout)
(dft
"min-connections"
~description:
"Strict minimum number of connections (triggers an urgent \
maintenance)."
uint16
default_p2p_limits.min_connections)
(dft
"expected-connections"
~description:
"Targeted number of connections to reach when bootstrapping \
/ maintaining."
uint16
default_p2p_limits.expected_connections)
(dft
"max-connections"
~description:
"Maximum number of connections (exceeding peers are \
disconnected)."
uint16
default_p2p_limits.max_connections)
(dft
"backlog"
~description:
"Number above which pending incoming connections are \
immediately rejected."
uint8
default_p2p_limits.backlog)
(dft
"max-incoming-connections"
~description:
"Number above which pending incoming connections are \
immediately rejected."
uint8
default_p2p_limits.max_incoming_connections)
(opt
"max-download-speed"
~description:"Max download speeds in KiB/s."
int31)
(opt
"max-upload-speed"
~description:"Max upload speeds in KiB/s."
int31)
(dft
"swap-linger"
Time.System.Span.encoding
default_p2p_limits.swap_linger))
(obj10
(opt "binary-chunks-size" uint8)
(dft
"read-buffer-size"
~description:"Size of the buffer passed to read(2)."
int31
default_p2p_limits.read_buffer_size)
(opt "read-queue-size" int31)
(opt "write-queue-size" int31)
(opt "incoming-app-message-queue-size" int31)
(opt "incoming-message-queue-size" int31)
(opt "outgoing-message-queue-size" int31)
(dft
"known_points_history_size"
uint16
default_p2p_limits.known_points_history_size)
(dft
"known_peer_ids_history_size"
uint16
default_p2p_limits.known_points_history_size)
(opt "max_known_points" (tup2 uint16 uint16))))
(obj3
(opt "max_known_peer_ids" (tup2 uint16 uint16))
(dft
"greylist-timeout"
~description:"GC delay for the greylists tables, in seconds."
Time.System.Span.encoding
default_p2p_limits.greylist_timeout)
(dft
"maintenance-idle-time"
~description:
"How long to wait at most, in seconds, before running a \
maintenance loop."
Time.System.Span.encoding
default_p2p_limits.maintenance_idle_time)))
let p2p =
let open Data_encoding in
conv
(fun { expected_pow;
bootstrap_peers;
listen_addr;
discovery_addr;
private_mode;
limits;
disable_mempool;
disable_testchain;
greylisting_config } ->
( expected_pow,
bootstrap_peers,
listen_addr,
discovery_addr,
private_mode,
limits,
disable_mempool,
disable_testchain,
greylisting_config ))
(fun ( expected_pow,
bootstrap_peers,
listen_addr,
discovery_addr,
private_mode,
limits,
disable_mempool,
disable_testchain,
greylisting_config ) ->
{
expected_pow;
bootstrap_peers;
listen_addr;
discovery_addr;
private_mode;
limits;
disable_mempool;
disable_testchain;
greylisting_config;
})
(obj9
(dft
"expected-proof-of-work"
~description:
"Floating point number between 0 and 256 that represents a \
difficulty, 24 signifies for example that at least 24 leading \
zeroes are expected in the hash."
float
default_p2p.expected_pow)
(dft
"bootstrap-peers"
~description:
"List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. If \
the port is not specified, default port 9732 will be assumed."
(list string)
default_p2p.bootstrap_peers)
(opt
"listen-addr"
~description:
"Host to listen to. If the port is not specified, the default \
port 8732 will be assumed."
string)
(dft
"discovery-addr"
~description:
"Host for local peer discovery. If the port is not specified, the \
default port 10732 will be assumed."
(option string)
default_p2p.discovery_addr)
(dft
"private-mode"
~description:
"Specify if the node is in private mode or not. A node in private \
mode rejects incoming connections from untrusted peers and only \
opens outgoing connections to peers listed in 'bootstrap-peers' \
or provided with '--peer' option. Moreover, these peers will \
keep the identity and the address of the private node secret."
bool
false)
(dft "limits" ~description:"Network limits" limit default_p2p_limits)
(dft
"disable_mempool"
~description:
"If set to [true], the node will not participate in the \
propagation of pending operations (mempool). Default value is \
[false]. It can be used to decrease the memory and computation \
footprints of the node."
bool
false)
(dft
"disable_testchain"
~description:
"If set to [true], the node will not spawn a testchain during the \
protocol's testing voting period. Default value is [false]. It \
may be used used to decrease the node storage usage and \
computation by droping the validation of the test network blocks."
bool
false)
(let open P2p_point_state.Info in
dft
"greylisting_config"
~description:"The greylisting policy."
greylisting_config_encoding
default_greylisting_config))
let rpc : rpc Data_encoding.t =
let open Data_encoding in
conv
(fun {cors_origins; cors_headers; listen_addrs; tls} ->
let (cert, key) =
match tls with
| None ->
(None, None)
| Some {cert; key} ->
(Some cert, Some key)
in
(Some listen_addrs, None, cors_origins, cors_headers, cert, key))
(fun ( listen_addrs,
legacy_listen_addr,
cors_origins,
cors_headers,
cert,
key ) ->
let tls =
match (cert, key) with
| (None, _) | (_, None) ->
None
| (Some cert, Some key) ->
Some {cert; key}
in
let listen_addrs =
match (listen_addrs, legacy_listen_addr) with
| (Some addrs, None) ->
addrs
| (None, Some addr) ->
[addr]
| (None, None) ->
default_rpc.listen_addrs
| (Some _, Some _) ->
Pervasives.failwith
"Config file: Use only \"listen-addrs\" and not (legacy) \
\"listen-addr\"."
in
{listen_addrs; cors_origins; cors_headers; tls})
(obj6
(opt
"listen-addrs"
~description:
"Hosts to listen to. If the port is not specified, the default \
port 8732 will be assumed."
(list string))
(opt "listen-addr" ~description:"Legacy value: Host to listen to" string)
(dft
"cors-origin"
~description:
"Cross Origin Resource Sharing parameters, see \
https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
(list string)
default_rpc.cors_origins)
(dft
"cors-headers"
~description:
"Cross Origin Resource Sharing parameters, see \
https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
(list string)
default_rpc.cors_headers)
(opt
"crt"
~description:"Certificate file (necessary when TLS is used)."
string)
(opt "key" ~description:"Key file (necessary when TLS is used)." string))
let worker_limits_encoding default_size default_level =
let open Data_encoding in
conv
(fun {Worker_types.backlog_size; backlog_level} ->
(backlog_size, backlog_level))
(fun (backlog_size, backlog_level) -> {backlog_size; backlog_level})
(obj2
(dft "worker_backlog_size" uint16 default_size)
(dft "worker_backlog_level" Internal_event.Level.encoding default_level))
let timeout_encoding = Time.System.Span.encoding
let block_validator_limits_encoding =
let open Data_encoding in
conv
(fun {Node.protocol_timeout; worker_limits} ->
(protocol_timeout, worker_limits))
(fun (protocol_timeout, worker_limits) ->
{protocol_timeout; worker_limits})
(merge_objs
(obj1
(dft
"protocol_request_timeout"
timeout_encoding
default_shell.block_validator_limits.protocol_timeout))
(worker_limits_encoding
default_shell.block_validator_limits.worker_limits.backlog_size
default_shell.block_validator_limits.worker_limits.backlog_level))
let prevalidator_limits_encoding =
let open Data_encoding in
conv
(fun { Node.operation_timeout;
max_refused_operations;
operations_batch_size;
worker_limits } ->
( (operation_timeout, max_refused_operations, operations_batch_size),
worker_limits ))
(fun ( (operation_timeout, max_refused_operations, operations_batch_size),
worker_limits ) ->
{
operation_timeout;
max_refused_operations;
operations_batch_size;
worker_limits;
})
(merge_objs
(obj3
(dft
"operations_request_timeout"
timeout_encoding
default_shell.prevalidator_limits.operation_timeout)
(dft
"max_refused_operations"
uint16
default_shell.prevalidator_limits.max_refused_operations)
(dft
"operations_batch_size"
int31
default_shell.prevalidator_limits.operations_batch_size))
(worker_limits_encoding
default_shell.prevalidator_limits.worker_limits.backlog_size
default_shell.prevalidator_limits.worker_limits.backlog_level))
let peer_validator_limits_encoding =
let open Data_encoding in
let default_limits = default_shell.peer_validator_limits in
conv
(fun { Node.block_header_timeout;
block_operations_timeout;
protocol_timeout;
new_head_request_timeout;
worker_limits } ->
( ( block_header_timeout,
block_operations_timeout,
protocol_timeout,
new_head_request_timeout ),
worker_limits ))
(fun ( ( block_header_timeout,
block_operations_timeout,
protocol_timeout,
new_head_request_timeout ),
worker_limits ) ->
{
block_header_timeout;
block_operations_timeout;
protocol_timeout;
new_head_request_timeout;
worker_limits;
})
(merge_objs
(obj4
(dft
"block_header_request_timeout"
timeout_encoding
default_limits.block_header_timeout)
(dft
"block_operations_request_timeout"
timeout_encoding
default_limits.block_operations_timeout)
(dft
"protocol_request_timeout"
timeout_encoding
default_limits.protocol_timeout)
(dft
"new_head_request_timeout"
timeout_encoding
default_limits.new_head_request_timeout))
(worker_limits_encoding
default_limits.worker_limits.backlog_size
default_limits.worker_limits.backlog_level))
let chain_validator_limits_encoding =
let open Data_encoding in
conv
(fun {Node.bootstrap_threshold; worker_limits} ->
(bootstrap_threshold, worker_limits))
(fun (bootstrap_threshold, worker_limits) ->
{bootstrap_threshold; worker_limits})
(merge_objs
(obj1
(dft
"bootstrap_threshold"
~description:
"Set the number of peers with whom a chain synchronization \
must be completed to bootstrap the node."
uint8
default_shell.chain_validator_limits.bootstrap_threshold))
(worker_limits_encoding
default_shell.chain_validator_limits.worker_limits.backlog_size
default_shell.chain_validator_limits.worker_limits.backlog_level))
let shell =
let open Data_encoding in
conv
(fun { peer_validator_limits;
block_validator_limits;
prevalidator_limits;
chain_validator_limits;
history_mode } ->
( peer_validator_limits,
block_validator_limits,
prevalidator_limits,
chain_validator_limits,
history_mode ))
(fun ( peer_validator_limits,
block_validator_limits,
prevalidator_limits,
chain_validator_limits,
history_mode ) ->
{
peer_validator_limits;
block_validator_limits;
prevalidator_limits;
chain_validator_limits;
history_mode;
})
(obj5
(dft
"peer_validator"
peer_validator_limits_encoding
default_shell.peer_validator_limits)
(dft
"block_validator"
block_validator_limits_encoding
default_shell.block_validator_limits)
(dft
"prevalidator"
prevalidator_limits_encoding
default_shell.prevalidator_limits)
(dft
"chain_validator"
chain_validator_limits_encoding
default_shell.chain_validator_limits)
(opt "history_mode" History_mode.encoding))
let encoding =
let open Data_encoding in
conv
(fun {data_dir; rpc; p2p; log; internal_events; shell} ->
(data_dir, rpc, p2p, log, internal_events, shell))
(fun (data_dir, rpc, p2p, log, internal_events, shell) ->
{data_dir; rpc; p2p; log; internal_events; shell})
(obj6
(dft
"data-dir"
~description:"Location of the data dir on disk."
string
default_data_dir)
(dft
"rpc"
~description:"Configuration of rpc parameters"
rpc
default_rpc)
(req "p2p" ~description:"Configuration of network parameters" p2p)
(dft
"log"
~description:
"Configuration of the Lwt-log sink (part of the logging framework)"
Lwt_log_sink_unix.cfg_encoding
Lwt_log_sink_unix.default_cfg)
(dft
"internal-events"
~description:"Configuration of the structured logging framework"
Internal_event_unix.Configuration.encoding
Internal_event_unix.Configuration.default)
(dft
"shell"
~description:"Configuration of network parameters"
shell
default_shell))
let read fp =
if Sys.file_exists fp then
Lwt_utils_unix.Json.read_file fp
>>=? fun json ->
try return (Data_encoding.Json.destruct encoding json)
with exn -> fail (Exn exn)
else return default_config
let write fp cfg =
Node_data_version.ensure_data_dir (Filename.dirname fp)
>>=? fun () ->
Lwt_utils_unix.Json.write_file fp (Data_encoding.Json.construct encoding cfg)
let to_string cfg =
Data_encoding.Json.to_string (Data_encoding.Json.construct encoding cfg)
let update ?data_dir ?min_connections ?expected_connections ?max_connections
?max_download_speed ?max_upload_speed ?binary_chunks_size ?peer_table_size
?expected_pow ?bootstrap_peers ?listen_addr ?discovery_addr
?(rpc_listen_addrs = []) ?(private_mode = false) ?(disable_mempool = false)
?(disable_testchain = false) ?(cors_origins = []) ?(cors_headers = [])
?rpc_tls ?log_output ?bootstrap_threshold ?history_mode cfg =
let data_dir = Option.unopt ~default:cfg.data_dir data_dir in
Node_data_version.ensure_data_dir data_dir
>>=? fun () ->
let peer_table_size =
Option.map peer_table_size ~f:(fun i -> (i, i / 4 * 3))
in
let unopt_list ~default = function [] -> default | l -> l in
let limits : P2p.limits =
{
cfg.p2p.limits with
min_connections =
Option.unopt ~default:cfg.p2p.limits.min_connections min_connections;
expected_connections =
Option.unopt
~default:cfg.p2p.limits.expected_connections
expected_connections;
max_connections =
Option.unopt ~default:cfg.p2p.limits.max_connections max_connections;
max_download_speed =
Option.first_some max_download_speed cfg.p2p.limits.max_download_speed;
max_upload_speed =
Option.first_some max_upload_speed cfg.p2p.limits.max_upload_speed;
max_known_points =
Option.first_some peer_table_size cfg.p2p.limits.max_known_points;
max_known_peer_ids =
Option.first_some peer_table_size cfg.p2p.limits.max_known_peer_ids;
binary_chunks_size = Option.map ~f:(fun x -> x lsl 10) binary_chunks_size;
}
in
let p2p : p2p =
{
expected_pow = Option.unopt ~default:cfg.p2p.expected_pow expected_pow;
bootstrap_peers =
Option.unopt ~default:cfg.p2p.bootstrap_peers bootstrap_peers;
listen_addr = Option.first_some listen_addr cfg.p2p.listen_addr;
discovery_addr = Option.first_some discovery_addr cfg.p2p.discovery_addr;
private_mode = cfg.p2p.private_mode || private_mode;
limits;
disable_mempool = cfg.p2p.disable_mempool || disable_mempool;
disable_testchain = cfg.p2p.disable_testchain || disable_testchain;
greylisting_config = cfg.p2p.greylisting_config;
}
and rpc : rpc =
{
listen_addrs = unopt_list ~default:cfg.rpc.listen_addrs rpc_listen_addrs;
cors_origins = unopt_list ~default:cfg.rpc.cors_origins cors_origins;
cors_headers = unopt_list ~default:cfg.rpc.cors_headers cors_headers;
tls = Option.first_some rpc_tls cfg.rpc.tls;
}
and log : Lwt_log_sink_unix.cfg =
{cfg.log with output = Option.unopt ~default:cfg.log.output log_output}
and shell : shell =
{
peer_validator_limits = cfg.shell.peer_validator_limits;
block_validator_limits = cfg.shell.block_validator_limits;
prevalidator_limits = cfg.shell.prevalidator_limits;
chain_validator_limits =
Option.unopt_map
~default:cfg.shell.chain_validator_limits
~f:(fun bootstrap_threshold ->
{cfg.shell.chain_validator_limits with bootstrap_threshold})
bootstrap_threshold;
history_mode = Option.first_some history_mode cfg.shell.history_mode;
}
in
let internal_events = cfg.internal_events in
return {data_dir; p2p; rpc; log; internal_events; shell}
let resolve_addr ~default_addr ?default_port ?(passive = false) peer =
let (addr, port) = P2p_point.Id.parse_addr_port peer in
let node = if addr = "" || addr = "_" then default_addr else addr
and service =
match (port, default_port) with
| ("", None) ->
invalid_arg ""
| ("", Some default_port) ->
string_of_int default_port
| (port, _) ->
port
in
Lwt_utils_unix.getaddrinfo ~passive ~node ~service
let resolve_addrs ~default_addr ?default_port ?passive peers =
Lwt_list.fold_left_s
(fun a peer ->
resolve_addr ~default_addr ?default_port ?passive peer
>>= fun points -> Lwt.return (List.rev_append points a))
[]
peers
let resolve_discovery_addrs discovery_addr =
resolve_addr
~default_addr:Ipaddr.V4.(to_string broadcast)
~default_port:default_discovery_port
~passive:true
discovery_addr
>>= fun addrs ->
let rec to_ipv4 acc = function
| [] ->
Lwt.return (List.rev acc)
| (ip, port) :: xs -> (
match Ipaddr.v4_of_v6 ip with
| Some v ->
to_ipv4 ((v, port) :: acc) xs
| None ->
Format.eprintf
"Warning: failed to convert %S to an ipv4 address@."
(Ipaddr.V6.to_string ip) ;
to_ipv4 acc xs )
in
to_ipv4 [] addrs
let resolve_listening_addrs listen_addr =
resolve_addr
~default_addr:"::"
~default_port:default_p2p_port
~passive:true
listen_addr
let resolve_rpc_listening_addrs listen_addr =
resolve_addr
~default_addr:"::"
~default_port:default_rpc_port
~passive:true
listen_addr
let resolve_bootstrap_addrs peers =
resolve_addrs ~default_addr:"::" ~default_port:default_p2p_port peers
let check_listening_addrs config =
match config.p2p.listen_addr with
| None ->
Lwt.return_unit
| Some addr ->
Lwt.catch
(fun () ->
resolve_listening_addrs addr
>>= function
| [] ->
Format.eprintf "Warning: failed to resolve %S\n@." addr ;
Lwt.return_unit
| _ :: _ ->
Lwt.return_unit)
(function
| Invalid_argument msg ->
Format.eprintf "Warning: failed to parse %S: %s\n@." addr msg ;
Lwt.return_unit
| exn ->
Lwt.fail exn)
let check_discovery_addr config =
match config.p2p.discovery_addr with
| None ->
Lwt.return_unit
| Some addr ->
Lwt.catch
(fun () ->
resolve_discovery_addrs addr
>>= function
| [] ->
Format.eprintf "Warning: failed to resolve %S\n@." addr ;
Lwt.return_unit
| _ :: _ ->
Lwt.return_unit)
(function
| Invalid_argument msg ->
Format.eprintf "Warning: failed to parse %S: %s\n@." addr msg ;
Lwt.return_unit
| exn ->
Lwt.fail exn)
let check_rpc_listening_addr config =
Lwt_list.iter_p
(fun addr ->
Lwt.catch
(fun () ->
resolve_rpc_listening_addrs addr
>>= function
| [] ->
Format.eprintf "Warning: failed to resolve %S\n@." addr ;
Lwt.return_unit
| _ :: _ ->
Lwt.return_unit)
(function
| Invalid_argument msg ->
Format.eprintf "Warning: failed to parse %S: %s\n@." addr msg ;
Lwt.return_unit
| exn ->
Lwt.fail exn))
config.rpc.listen_addrs
let check_bootstrap_peer addr =
Lwt.catch
(fun () ->
resolve_bootstrap_addrs [addr]
>>= function
| [] ->
Format.eprintf "Warning: cannot resolve %S\n@." addr ;
Lwt.return_unit
| _ :: _ ->
Lwt.return_unit)
(function
| Invalid_argument msg ->
Format.eprintf "Warning: failed to parse %S: %s\n@." addr msg ;
Lwt.return_unit
| exn ->
Lwt.fail exn)
let check_bootstrap_peers config =
Lwt_list.iter_p check_bootstrap_peer config.p2p.bootstrap_peers
let fail fmt = Format.kasprintf (fun s -> prerr_endline s ; exit 1) fmt
let check_connections config =
if config.p2p.limits.min_connections > config.p2p.limits.expected_connections
then
fail
"Error: The minumum number of connections is greater than the expected \
number of connections"
config.p2p.limits.min_connections
config.p2p.limits.expected_connections ;
if config.p2p.limits.expected_connections > config.p2p.limits.max_connections
then
fail
"Error: The expected number of connections is greater than the maximum \
number of connections"
config.p2p.limits.expected_connections
config.p2p.limits.max_connections ;
( match config.p2p.limits.max_known_peer_ids with
| None ->
()
| Some (max_known_peer_ids, target_known_peer_ids) ->
if target_known_peer_ids > max_known_peer_ids then
fail
"Error: The target number of known peer ids is greater than the \
maximum number of known peer ids."
target_known_peer_ids
max_known_peer_ids ;
if config.p2p.limits.max_connections > target_known_peer_ids then
fail
"Error: The target number of known peer ids is lower than the \
maximum number of connections."
target_known_peer_ids
max_known_peer_ids ) ;
match config.p2p.limits.max_known_points with
| None ->
()
| Some (max_known_points, target_known_points) ->
if target_known_points > max_known_points then
fail
"Error: The target number of known points is greater than the \
maximum number of known points."
target_known_points
max_known_points ;
if config.p2p.limits.max_connections > target_known_points then
fail
"Error: The target number of known points is lower than the maximum \
number of connections."
target_known_points
max_known_points
let check config =
check_listening_addrs config
>>= fun () ->
check_rpc_listening_addr config
>>= fun () ->
check_discovery_addr config
>>= fun () ->
check_bootstrap_peers config
>>= fun () -> check_connections config ; Lwt.return_unit
src/bin_node/node_config_file.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition home : string :=
(* ❌ Try-with are not handled *)
try (Sys.getenv "HOME" % string).
Definition default_data_dir : string := op_divdiv home ".tezos-node" % string.
Definition default_rpc_port : Z := 8732.
Definition default_p2p_port : Z := 9732.
Definition default_discovery_port : Z := 10732.
.
Definition default_p2p_limits : Tezos_p2p.P2p.limits :=
{|
connection_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 10. is approximated by the integer 10 *)
10;
authentication_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 5. is approximated by the integer 5 *)
5;
greylist_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 86400. is approximated by the integer 86400 *)
86400;
maintenance_idle_time :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 120. is approximated by the integer 120 *)
120; min_connections := 10; expected_connections := 50;
max_connections := 100; backlog := 20; max_incoming_connections := 20;
max_download_speed := None; max_upload_speed := None;
read_buffer_size := Z.shiftl 1 14; read_queue_size := None;
write_queue_size := None; incoming_app_message_queue_size := None;
incoming_message_queue_size := None; outgoing_message_queue_size := None;
known_peer_ids_history_size := 500; known_points_history_size := 500;
max_known_peer_ids := Some (400, 300); max_known_points := Some (400, 300);
swap_linger :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 30. is approximated by the integer 30 *)
30; binary_chunks_size := None |}.
Definition default_p2p : p2p :=
{|
expected_pow :=
(* ❌ Float constant 26. is approximated by the integer 26 *)
26; bootstrap_peers := [];
listen_addr :=
Some
(String.append "[::]:" % string
(OCaml.Stdlib.string_of_int default_p2p_port));
discovery_addr := None; private_mode := false; limits := default_p2p_limits;
disable_mempool := false; disable_testchain := false;
greylisting_config := P2p_point_state.Info.default_greylisting_config |}.
Definition default_rpc : rpc :=
{| listen_addrs := []; cors_origins := []; cors_headers := []; tls := None |}.
Definition default_shell : shell :=
{| block_validator_limits := Node.default_block_validator_limits;
prevalidator_limits := Node.default_prevalidator_limits;
peer_validator_limits := Node.default_peer_validator_limits;
chain_validator_limits := Node.default_chain_validator_limits;
history_mode := None |}.
Definition default_config : t :=
{| data_dir := default_data_dir; p2p := default_p2p; rpc := default_rpc;
log := Lwt_log_sink_unix.default_cfg;
internal_events := Internal_event_unix.Configuration.default;
shell := default_shell |}.
Definition limit
: Tezos_base__TzPervasives.Data_encoding.t Tezos_p2p.P2p.limits :=
conv
(fun function_parameter =>
let '{|
P2p.connection_timeout := connection_timeout;
P2p.authentication_timeout := authentication_timeout;
P2p.greylist_timeout := greylist_timeout;
P2p.maintenance_idle_time := maintenance_idle_time;
P2p.min_connections := min_connections;
P2p.expected_connections := expected_connections;
P2p.max_connections := max_connections;
P2p.backlog := backlog;
P2p.max_incoming_connections := max_incoming_connections;
P2p.max_download_speed := max_download_speed;
P2p.max_upload_speed := max_upload_speed;
P2p.read_buffer_size := read_buffer_size;
P2p.read_queue_size := read_queue_size;
P2p.write_queue_size := write_queue_size;
P2p.incoming_app_message_queue_size := incoming_app_message_queue_size;
P2p.incoming_message_queue_size := incoming_message_queue_size;
P2p.outgoing_message_queue_size := outgoing_message_queue_size;
P2p.known_peer_ids_history_size := known_peer_ids_history_size;
P2p.known_points_history_size := known_points_history_size;
P2p.max_known_peer_ids := max_known_peer_ids;
P2p.max_known_points := max_known_points;
P2p.swap_linger := swap_linger;
P2p.binary_chunks_size := binary_chunks_size
|} := function_parameter in
(((connection_timeout, authentication_timeout, min_connections,
expected_connections, max_connections, backlog,
max_incoming_connections, max_download_speed, max_upload_speed,
swap_linger),
(binary_chunks_size, read_buffer_size, read_queue_size,
write_queue_size, incoming_app_message_queue_size,
incoming_message_queue_size, outgoing_message_queue_size,
known_points_history_size, known_peer_ids_history_size,
max_known_points)),
(max_known_peer_ids, greylist_timeout, maintenance_idle_time)))
(fun function_parameter =>
let
'(((connection_timeout, authentication_timeout, min_connections,
expected_connections, max_connections, backlog,
max_incoming_connections, max_download_speed, max_upload_speed,
swap_linger),
(binary_chunks_size, read_buffer_size, read_queue_size,
write_queue_size, incoming_app_message_queue_size,
incoming_message_queue_size, outgoing_message_queue_size,
known_points_history_size, known_peer_ids_history_size,
max_known_points)),
(max_known_peer_ids, greylist_timeout, maintenance_idle_time)) :=
function_parameter in
{| connection_timeout := connection_timeout;
authentication_timeout := authentication_timeout;
greylist_timeout := greylist_timeout;
maintenance_idle_time := maintenance_idle_time;
min_connections := min_connections;
expected_connections := expected_connections;
max_connections := max_connections; backlog := backlog;
max_incoming_connections := max_incoming_connections;
max_download_speed := max_download_speed;
max_upload_speed := max_upload_speed;
read_buffer_size := read_buffer_size;
read_queue_size := read_queue_size;
write_queue_size := write_queue_size;
incoming_app_message_queue_size := incoming_app_message_queue_size;
incoming_message_queue_size := incoming_message_queue_size;
outgoing_message_queue_size := outgoing_message_queue_size;
known_peer_ids_history_size := known_peer_ids_history_size;
known_points_history_size := known_points_history_size;
max_known_peer_ids := max_known_peer_ids;
max_known_points := max_known_points; swap_linger := swap_linger;
binary_chunks_size := binary_chunks_size |}) None
(merge_objs
(merge_objs
(obj10
(dft None
(Some
"Delay acceptable when initiating a connection to a new peer, in seconds."
% string) "connection-timeout" % string
Time.System.Span.encoding
(authentication_timeout default_p2p_limits))
(dft None
(Some
"Delay granted to a peer to perform authentication, in seconds." %
string) "authentication-timeout" % string
Time.System.Span.encoding
(authentication_timeout default_p2p_limits))
(dft None
(Some
"Strict minimum number of connections (triggers an urgent maintenance)."
% string) "min-connections" % string uint16
(min_connections default_p2p_limits))
(dft None
(Some
"Targeted number of connections to reach when bootstrapping / maintaining."
% string) "expected-connections" % string uint16
(expected_connections default_p2p_limits))
(dft None
(Some
"Maximum number of connections (exceeding peers are disconnected)."
% string) "max-connections" % string uint16
(max_connections default_p2p_limits))
(dft None
(Some
"Number above which pending incoming connections are immediately rejected."
% string) "backlog" % string uint8 (backlog default_p2p_limits))
(dft None
(Some
"Number above which pending incoming connections are immediately rejected."
% string) "max-incoming-connections" % string uint8
(max_incoming_connections default_p2p_limits))
(opt None (Some "Max download speeds in KiB/s." % string)
"max-download-speed" % string int31)
(opt None (Some "Max upload speeds in KiB/s." % string)
"max-upload-speed" % string int31)
(dft None None "swap-linger" % string Time.System.Span.encoding
(swap_linger default_p2p_limits)))
(obj10 (opt None None "binary-chunks-size" % string uint8)
(dft None (Some "Size of the buffer passed to read(2)." % string)
"read-buffer-size" % string int31
(read_buffer_size default_p2p_limits))
(opt None None "read-queue-size" % string int31)
(opt None None "write-queue-size" % string int31)
(opt None None "incoming-app-message-queue-size" % string int31)
(opt None None "incoming-message-queue-size" % string int31)
(opt None None "outgoing-message-queue-size" % string int31)
(dft None None "known_points_history_size" % string uint16
(known_points_history_size default_p2p_limits))
(dft None None "known_peer_ids_history_size" % string uint16
(known_points_history_size default_p2p_limits))
(opt None None "max_known_points" % string (tup2 uint16 uint16))))
(obj3 (opt None None "max_known_peer_ids" % string (tup2 uint16 uint16))
(dft None
(Some "GC delay for the greylists tables, in seconds." % string)
"greylist-timeout" % string Time.System.Span.encoding
(greylist_timeout default_p2p_limits))
(dft None
(Some
"How long to wait at most, in seconds, before running a maintenance loop."
% string) "maintenance-idle-time" % string
Time.System.Span.encoding (maintenance_idle_time default_p2p_limits)))).
Definition p2p : Tezos_base__TzPervasives.Data_encoding.encoding p2p :=
conv
(fun function_parameter =>
let '{|
expected_pow := expected_pow;
bootstrap_peers := bootstrap_peers;
listen_addr := listen_addr;
discovery_addr := discovery_addr;
private_mode := private_mode;
limits := limits;
disable_mempool := disable_mempool;
disable_testchain := disable_testchain;
greylisting_config := greylisting_config
|} := function_parameter in
(expected_pow, bootstrap_peers, listen_addr, discovery_addr, private_mode,
limits, disable_mempool, disable_testchain, greylisting_config))
(fun function_parameter =>
let
'(expected_pow, bootstrap_peers, listen_addr, discovery_addr,
private_mode, limits, disable_mempool, disable_testchain,
greylisting_config) := function_parameter in
{| expected_pow := expected_pow; bootstrap_peers := bootstrap_peers;
listen_addr := listen_addr; discovery_addr := discovery_addr;
private_mode := private_mode; limits := limits;
disable_mempool := disable_mempool;
disable_testchain := disable_testchain;
greylisting_config := greylisting_config |}) None
(obj9
(dft None
(Some
"Floating point number between 0 and 256 that represents a difficulty, 24 signifies for example that at least 24 leading zeroes are expected in the hash."
% string) "expected-proof-of-work" % string float
(expected_pow default_p2p))
(dft None
(Some
"List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. If the port is not specified, default port 9732 will be assumed."
% string) "bootstrap-peers" % string (list None string)
(bootstrap_peers default_p2p))
(opt None
(Some
"Host to listen to. If the port is not specified, the default port 8732 will be assumed."
% string) "listen-addr" % string string)
(dft None
(Some
"Host for local peer discovery. If the port is not specified, the default port 10732 will be assumed."
% string) "discovery-addr" % string (option string)
(discovery_addr default_p2p))
(dft None
(Some
"Specify if the node is in private mode or not. A node in private mode rejects incoming connections from untrusted peers and only opens outgoing connections to peers listed in 'bootstrap-peers' or provided with '--peer' option. Moreover, these peers will keep the identity and the address of the private node secret."
% string) "private-mode" % string bool false)
(dft None (Some "Network limits" % string) "limits" % string limit
default_p2p_limits)
(dft None
(Some
"If set to [true], the node will not participate in the propagation of pending operations (mempool). Default value is [false]. It can be used to decrease the memory and computation footprints of the node."
% string) "disable_mempool" % string bool false)
(dft None
(Some
"If set to [true], the node will not spawn a testchain during the protocol's testing voting period. Default value is [false]. It may be used used to decrease the node storage usage and computation by droping the validation of the test network blocks."
% string) "disable_testchain" % string bool false)
(dft None (Some "The greylisting policy." % string)
"greylisting_config" % string greylisting_config_encoding
default_greylisting_config)).
Definition rpc : Tezos_base__TzPervasives.Data_encoding.t rpc :=
conv
(fun function_parameter =>
let '{|
listen_addrs := listen_addrs;
cors_origins := cors_origins;
cors_headers := cors_headers;
tls := tls
|} := function_parameter in
let '(cert, key) :=
match tls with
| None => (None, None)
| Some {| cert := cert; key := key |} => ((Some cert), (Some key))
end in
((Some listen_addrs), None, cors_origins, cors_headers, cert, key))
(fun function_parameter =>
let
'(listen_addrs, legacy_listen_addr, cors_origins, cors_headers, cert,
key) := function_parameter in
let tls :=
match (cert, key) with
| (None, _) | (_, None) => None
| (Some cert, Some key) => Some {| cert := cert; key := key |}
end in
let listen_addrs :=
match (listen_addrs, legacy_listen_addr) with
| (Some addrs, None) => addrs
| (None, Some addr) => cons addr []
| (None, None) => listen_addrs default_rpc
| (Some _, Some _) =>
Pervasives.failwith
"Config file: Use only ""listen-addrs"" and not (legacy) ""listen-addr""."
% string
end in
{| listen_addrs := listen_addrs; cors_origins := cors_origins;
cors_headers := cors_headers; tls := tls |}) None
(obj6
(opt None
(Some
"Hosts to listen to. If the port is not specified, the default port 8732 will be assumed."
% string) "listen-addrs" % string (list None string))
(opt None (Some "Legacy value: Host to listen to" % string)
"listen-addr" % string string)
(dft None
(Some
"Cross Origin Resource Sharing parameters, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
% string) "cors-origin" % string (list None string)
(cors_origins default_rpc))
(dft None
(Some
"Cross Origin Resource Sharing parameters, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
% string) "cors-headers" % string (list None string)
(cors_headers default_rpc))
(opt None (Some "Certificate file (necessary when TLS is used)." % string)
"crt" % string string)
(opt None (Some "Key file (necessary when TLS is used)." % string)
"key" % string string)).
Definition worker_limits_encoding
(default_size : Z)
(default_level : Tezos_base__TzPervasives.Internal_event.Level.t)
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell_services.Worker_types.limits :=
conv
(fun function_parameter =>
let '{|
Worker_types.backlog_size := backlog_size;
Worker_types.backlog_level := backlog_level
|} := function_parameter in
(backlog_size, backlog_level))
(fun function_parameter =>
let '(backlog_size, backlog_level) := function_parameter in
{| backlog_size := backlog_size; backlog_level := backlog_level |}) None
(obj2 (dft None None "worker_backlog_size" % string uint16 default_size)
(dft None None "worker_backlog_level" % string
Internal_event.Level.encoding default_level)).
Definition timeout_encoding
: Tezos_data_encoding.Data_encoding.t
Tezos_base__TzPervasives.Time.System.Span.t := Time.System.Span.encoding.
Definition block_validator_limits_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell.Node.block_validator_limits :=
conv
(fun function_parameter =>
let '{|
Node.protocol_timeout := protocol_timeout;
Node.worker_limits := worker_limits
|} := function_parameter in
(protocol_timeout, worker_limits))
(fun function_parameter =>
let '(protocol_timeout, worker_limits) := function_parameter in
{| protocol_timeout := protocol_timeout; worker_limits := worker_limits |})
None
(merge_objs
(obj1
(dft None None "protocol_request_timeout" % string timeout_encoding
(protocol_timeout (block_validator_limits default_shell))))
(worker_limits_encoding
(backlog_size (worker_limits (block_validator_limits default_shell)))
(backlog_level (worker_limits (block_validator_limits default_shell))))).
Definition prevalidator_limits_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell.Node.prevalidator_limits :=
conv
(fun function_parameter =>
let '{|
Node.max_refused_operations := max_refused_operations;
Node.operation_timeout := operation_timeout;
Node.worker_limits := worker_limits;
Node.operations_batch_size := operations_batch_size
|} := function_parameter in
((operation_timeout, max_refused_operations, operations_batch_size),
worker_limits))
(fun function_parameter =>
let
'((operation_timeout, max_refused_operations, operations_batch_size),
worker_limits) := function_parameter in
{| max_refused_operations := max_refused_operations;
operation_timeout := operation_timeout; worker_limits := worker_limits;
operations_batch_size := operations_batch_size |}) None
(merge_objs
(obj3
(dft None None "operations_request_timeout" % string timeout_encoding
(operation_timeout (prevalidator_limits default_shell)))
(dft None None "max_refused_operations" % string uint16
(max_refused_operations (prevalidator_limits default_shell)))
(dft None None "operations_batch_size" % string int31
(operations_batch_size (prevalidator_limits default_shell))))
(worker_limits_encoding
(backlog_size (worker_limits (prevalidator_limits default_shell)))
(backlog_level (worker_limits (prevalidator_limits default_shell))))).
Definition peer_validator_limits_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell.Node.peer_validator_limits :=
let default_limits := peer_validator_limits default_shell in
conv
(fun function_parameter =>
let '{|
Node.new_head_request_timeout := new_head_request_timeout;
Node.block_header_timeout := block_header_timeout;
Node.block_operations_timeout := block_operations_timeout;
Node.protocol_timeout := protocol_timeout;
Node.worker_limits := worker_limits
|} := function_parameter in
((block_header_timeout, block_operations_timeout, protocol_timeout,
new_head_request_timeout), worker_limits))
(fun function_parameter =>
let
'((block_header_timeout, block_operations_timeout, protocol_timeout,
new_head_request_timeout), worker_limits) := function_parameter in
{| new_head_request_timeout := new_head_request_timeout;
block_header_timeout := block_header_timeout;
block_operations_timeout := block_operations_timeout;
protocol_timeout := protocol_timeout; worker_limits := worker_limits |})
None
(merge_objs
(obj4
(dft None None "block_header_request_timeout" % string timeout_encoding
(block_header_timeout default_limits))
(dft None None "block_operations_request_timeout" % string
timeout_encoding (block_operations_timeout default_limits))
(dft None None "protocol_request_timeout" % string timeout_encoding
(protocol_timeout default_limits))
(dft None None "new_head_request_timeout" % string timeout_encoding
(new_head_request_timeout default_limits)))
(worker_limits_encoding (backlog_size (worker_limits default_limits))
(backlog_level (worker_limits default_limits)))).
Definition chain_validator_limits_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell.Node.chain_validator_limits :=
conv
(fun function_parameter =>
let '{|
Node.bootstrap_threshold := bootstrap_threshold;
Node.worker_limits := worker_limits
|} := function_parameter in
(bootstrap_threshold, worker_limits))
(fun function_parameter =>
let '(bootstrap_threshold, worker_limits) := function_parameter in
{| bootstrap_threshold := bootstrap_threshold;
worker_limits := worker_limits |}) None
(merge_objs
(obj1
(dft None
(Some
"Set the number of peers with whom a chain synchronization must be completed to bootstrap the node."
% string) "bootstrap_threshold" % string uint8
(bootstrap_threshold (chain_validator_limits default_shell))))
(worker_limits_encoding
(backlog_size (worker_limits (chain_validator_limits default_shell)))
(backlog_level (worker_limits (chain_validator_limits default_shell))))).
Definition shell : Tezos_base__TzPervasives.Data_encoding.encoding shell :=
conv
(fun function_parameter =>
let '{|
block_validator_limits := block_validator_limits;
prevalidator_limits := prevalidator_limits;
peer_validator_limits := peer_validator_limits;
chain_validator_limits := chain_validator_limits;
history_mode := history_mode
|} := function_parameter in
(peer_validator_limits, block_validator_limits, prevalidator_limits,
chain_validator_limits, history_mode))
(fun function_parameter =>
let
'(peer_validator_limits, block_validator_limits, prevalidator_limits,
chain_validator_limits, history_mode) := function_parameter in
{| block_validator_limits := block_validator_limits;
prevalidator_limits := prevalidator_limits;
peer_validator_limits := peer_validator_limits;
chain_validator_limits := chain_validator_limits;
history_mode := history_mode |}) None
(obj5
(dft None None "peer_validator" % string peer_validator_limits_encoding
(peer_validator_limits default_shell))
(dft None None "block_validator" % string block_validator_limits_encoding
(block_validator_limits default_shell))
(dft None None "prevalidator" % string prevalidator_limits_encoding
(prevalidator_limits default_shell))
(dft None None "chain_validator" % string chain_validator_limits_encoding
(chain_validator_limits default_shell))
(opt None None "history_mode" % string History_mode.encoding)).
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
data_dir := data_dir;
p2p := p2p;
rpc := rpc;
log := log;
internal_events := internal_events;
shell := shell
|} := function_parameter in
(data_dir, rpc, p2p, log, internal_events, shell))
(fun function_parameter =>
let '(data_dir, rpc, p2p, log, internal_events, shell) :=
function_parameter in
{| data_dir := data_dir; p2p := p2p; rpc := rpc; log := log;
internal_events := internal_events; shell := shell |}) None
(obj6
(dft None (Some "Location of the data dir on disk." % string)
"data-dir" % string string default_data_dir)
(dft None (Some "Configuration of rpc parameters" % string) "rpc" % string
rpc default_rpc)
(req None (Some "Configuration of network parameters" % string)
"p2p" % string p2p)
(dft None
(Some
"Configuration of the Lwt-log sink (part of the logging framework)" %
string) "log" % string Lwt_log_sink_unix.cfg_encoding
Lwt_log_sink_unix.default_cfg)
(dft None
(Some "Configuration of the structured logging framework" % string)
"internal-events" % string Internal_event_unix.Configuration.encoding
Internal_event_unix.Configuration.default)
(dft None (Some "Configuration of network parameters" % string)
"shell" % string shell default_shell)).
Definition read (fp : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
if Sys.file_exists fp then
op_gtgteqquestion (Lwt_utils_unix.Json.read_file fp)
(fun json =>
(* ❌ Try-with are not handled *)
try (_return (Data_encoding.Json.destruct encoding json)))
else
_return default_config.
Definition write (fp : string) (cfg : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(Node_data_version.ensure_data_dir None (Filename.dirname fp))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.Json.write_file fp
(Data_encoding.Json.construct encoding cfg)).
Definition to_string (cfg : t) : string :=
Data_encoding.Json.to_string None None
(Data_encoding.Json.construct encoding cfg).
Definition update
(data_dir : option string) (min_connections : option Z)
(expected_connections : option Z) (max_connections : option Z)
(max_download_speed : option Z) (max_upload_speed : option Z)
(binary_chunks_size : option Z) (peer_table_size : option Z)
(expected_pow : option Z) (bootstrap_peers : option (list string))
(listen_addr : option string) (discovery_addr : option string)
(op_staroptstar : option (list string))
: (option bool) ->
(option bool) ->
(option bool) ->
(option (list string)) ->
(option (list string)) ->
(option tls) ->
(option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t) ->
(option Z) ->
(option Tezos_shell_services.History_mode.t) ->
t -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let rpc_listen_addrs :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let private_mode :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let disable_mempool :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let disable_testchain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let cors_origins :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let cors_headers :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun rpc_tls =>
fun log_output =>
fun bootstrap_threshold =>
fun history_mode =>
fun cfg =>
let data_dir := Option.unopt (data_dir cfg) data_dir in
op_gtgteqquestion
(Node_data_version.ensure_data_dir None data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
let peer_table_size :=
Option.map (fun i => (i, (Z.mul (Z.div i 4) 3)))
peer_table_size in
let unopt_list {A : Type}
(default : list A) (function_parameter : list A)
: list A :=
match function_parameter with
| [] => default
| l => l
end in
let limits :=
(* ❌ Record substitution not handled *)
record_substitution in
let p2p : p2p :=
{|
expected_pow :=
Option.unopt (expected_pow (p2p cfg))
expected_pow;
bootstrap_peers :=
Option.unopt (bootstrap_peers (p2p cfg))
bootstrap_peers;
listen_addr :=
Option.first_some listen_addr
(listen_addr (p2p cfg));
discovery_addr :=
Option.first_some discovery_addr
(discovery_addr (p2p cfg));
private_mode :=
orb (private_mode (p2p cfg)) private_mode;
limits := limits;
disable_mempool :=
orb (disable_mempool (p2p cfg)) disable_mempool;
disable_testchain :=
orb (disable_testchain (p2p cfg))
disable_testchain;
greylisting_config := greylisting_config (p2p cfg)
|}
with rpc : rpc :=
{|
listen_addrs :=
unopt_list (listen_addrs (rpc cfg))
rpc_listen_addrs;
cors_origins :=
unopt_list (cors_origins (rpc cfg)) cors_origins;
cors_headers :=
unopt_list (cors_headers (rpc cfg)) cors_headers;
tls := Option.first_some rpc_tls (tls (rpc cfg))
|}
with log : Tezos_stdlib_unix.Lwt_log_sink_unix.cfg :=
(* ❌ Record substitution not handled *)
record_substitution
with shell : shell :=
{|
block_validator_limits :=
block_validator_limits (shell cfg);
prevalidator_limits :=
prevalidator_limits (shell cfg);
peer_validator_limits :=
peer_validator_limits (shell cfg);
chain_validator_limits :=
Option.unopt_map
(fun bootstrap_threshold =>
(* ❌ Record substitution not handled *)
record_substitution)
(chain_validator_limits (shell cfg))
bootstrap_threshold;
history_mode :=
Option.first_some history_mode
(history_mode (shell cfg)) |} in
let internal_events := internal_events cfg in
_return
{| data_dir := data_dir; p2p := p2p; rpc := rpc;
log := log; internal_events := internal_events;
shell := shell |}).
Definition resolve_addr
(default_addr : string) (default_port : option Z)
(op_staroptstar : option bool) : string -> Lwt.t (list (Ipaddr.V6.t * Z)) :=
let passive :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun peer =>
let '(addr, port) := P2p_point.Id.parse_addr_port peer in
let node : string :=
if orb (equiv_decb addr "" % string) (equiv_decb addr "_" % string) then
default_addr
else
addr
with service : string :=
match (port, default_port) with
| ("" % string, None) => OCaml.Stdlib.invalid_arg "" % string
| ("" % string, Some default_port) =>
OCaml.Stdlib.string_of_int default_port
| (port, _) => port
end in
Lwt_utils_unix.getaddrinfo passive node service.
Definition resolve_addrs
(default_addr : string) (default_port : option Z) (passive : option bool)
(peers : list string) : Lwt.t (list (Ipaddr.V6.t * Z)) :=
Lwt_list.fold_left_s
(fun a =>
fun peer =>
op_gtgteq (resolve_addr default_addr default_port passive peer)
(fun points => Lwt._return (List.rev_append points a))) [] peers.
Definition resolve_discovery_addrs (discovery_addr : string)
: Lwt.t (list (Ipaddr.V4.t * Z)) :=
op_gtgteq
(resolve_addr (to_string broadcast) (Some default_discovery_port)
(Some true) discovery_addr)
(fun addrs =>
let fix to_ipv4 {A : Type}
(acc : list (Ipaddr.V4.t * A)) (function_parameter :
list (Ipaddr.V6.t * A)) : Lwt.t (list (Ipaddr.V4.t * A)) :=
match function_parameter with
| [] => Lwt._return (List.rev acc)
| cons (ip, port) xs =>
match Ipaddr.v4_of_v6 ip with
| Some v => to_ipv4 (cons (v, port) acc) xs
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to convert " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" to an ipv4 address" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: failed to convert %S to an ipv4 address@." % string)
(Ipaddr.V6.to_string ip) in
to_ipv4 acc xs
end
end in
to_ipv4 [] addrs).
Definition resolve_listening_addrs (listen_addr : string)
: Lwt.t (list (Ipaddr.V6.t * Z)) :=
resolve_addr "::" % string (Some default_p2p_port) (Some true) listen_addr.
Definition resolve_rpc_listening_addrs (listen_addr : string)
: Lwt.t (list (Ipaddr.V6.t * Z)) :=
resolve_addr "::" % string (Some default_rpc_port) (Some true) listen_addr.
Definition resolve_bootstrap_addrs (peers : list string)
: Lwt.t (list (Ipaddr.V6.t * Z)) :=
resolve_addrs "::" % string (Some default_p2p_port) None peers.
Definition check_listening_addrs (config : t) : Lwt.t unit :=
match listen_addr (p2p config) with
| None => Lwt.return_unit
| Some addr =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (resolve_listening_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to resolve " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: failed to resolve %S
@." % string) addr in
Lwt.return_unit
| cons _ _ => Lwt.return_unit
end))
(fun function_parameter =>
match function_parameter with
| OCaml.Invalid_argument msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Warning: failed to parse %S: %s
@." % string) addr msg in
Lwt.return_unit
| exn => Lwt.fail exn
end)
end.
Definition check_discovery_addr (config : t) : Lwt.t unit :=
match discovery_addr (p2p config) with
| None => Lwt.return_unit
| Some addr =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (resolve_discovery_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to resolve " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: failed to resolve %S
@." % string) addr in
Lwt.return_unit
| cons _ _ => Lwt.return_unit
end))
(fun function_parameter =>
match function_parameter with
| OCaml.Invalid_argument msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Warning: failed to parse %S: %s
@." % string) addr msg in
Lwt.return_unit
| exn => Lwt.fail exn
end)
end.
Definition check_rpc_listening_addr (config : t) : Lwt.t unit :=
Lwt_list.iter_p
(fun addr =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (resolve_rpc_listening_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to resolve " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: failed to resolve %S
@." % string) addr in
Lwt.return_unit
| cons _ _ => Lwt.return_unit
end))
(fun function_parameter =>
match function_parameter with
| OCaml.Invalid_argument msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Warning: failed to parse %S: %s
@." % string) addr msg in
Lwt.return_unit
| exn => Lwt.fail exn
end)) (listen_addrs (rpc config)).
Definition check_bootstrap_peer (addr : string) : Lwt.t unit :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (resolve_bootstrap_addrs (cons addr []))
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: cannot resolve " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: cannot resolve %S
@." % string) addr in
Lwt.return_unit
| cons _ _ => Lwt.return_unit
end))
(fun function_parameter =>
match function_parameter with
| OCaml.Invalid_argument msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Warning: failed to parse %S: %s
@." % string) addr msg in
Lwt.return_unit
| exn => Lwt.fail exn
end).
Definition check_bootstrap_peers (config : t) : Lwt.t unit :=
Lwt_list.iter_p check_bootstrap_peer (bootstrap_peers (p2p config)).
Definition fail {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
Format.kasprintf
(fun s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.prerr_endline s in
Stdlib.exit 1) fmt.
Definition check_connections (config : t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
OCaml.Stdlib.gt (min_connections (limits (p2p config)))
(expected_connections (limits (p2p config))) then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The minumum number of connections is greater than the expected number of connections"
% string CamlinternalFormatBasics.End_of_format)
"Error: The minumum number of connections is greater than the expected number of connections"
% string) (min_connections (limits (p2p config)))
(expected_connections (limits (p2p config)))
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
OCaml.Stdlib.gt (expected_connections (limits (p2p config)))
(max_connections (limits (p2p config))) then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The expected number of connections is greater than the maximum number of connections"
% string CamlinternalFormatBasics.End_of_format)
"Error: The expected number of connections is greater than the maximum number of connections"
% string) (expected_connections (limits (p2p config)))
(max_connections (limits (p2p config)))
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match max_known_peer_ids (limits (p2p config)) with
| None => tt
| Some (max_known_peer_ids, target_known_peer_ids) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt target_known_peer_ids max_known_peer_ids then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The target number of known peer ids is greater than the maximum number of known peer ids."
% string CamlinternalFormatBasics.End_of_format)
"Error: The target number of known peer ids is greater than the maximum number of known peer ids."
% string) target_known_peer_ids max_known_peer_ids
else
tt in
if
OCaml.Stdlib.gt (max_connections (limits (p2p config)))
target_known_peer_ids then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The target number of known peer ids is lower than the maximum number of connections."
% string CamlinternalFormatBasics.End_of_format)
"Error: The target number of known peer ids is lower than the maximum number of connections."
% string) target_known_peer_ids max_known_peer_ids
else
tt
end in
match max_known_points (limits (p2p config)) with
| None => tt
| Some (max_known_points, target_known_points) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt target_known_points max_known_points then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The target number of known points is greater than the maximum number of known points."
% string CamlinternalFormatBasics.End_of_format)
"Error: The target number of known points is greater than the maximum number of known points."
% string) target_known_points max_known_points
else
tt in
if
OCaml.Stdlib.gt (max_connections (limits (p2p config)))
target_known_points then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The target number of known points is lower than the maximum number of connections."
% string CamlinternalFormatBasics.End_of_format)
"Error: The target number of known points is lower than the maximum number of connections."
% string) target_known_points max_known_points
else
tt
end.
Definition check (config : t) : Lwt.t unit :=
op_gtgteq (check_listening_addrs config)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_rpc_listening_addr config)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_discovery_addr config)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_bootstrap_peers config)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_connections config in
Lwt.return_unit)))).
src/bin_node/node_data_version.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
type t = string
(* Data_version hitory:
* - 0.0.1 : original storage
* - 0.0.2 : never released
* - 0.0.3 : store upgrade (introducing history mode)
* - 0.0.4 : context upgrade (switching from LMDB to IRMIN v2) *)
let data_version = "0.0.4"
(* List of upgrade functions from each still supported previous
version to the current [data_version] above. If this list grows too
much, an idea would be to have triples (version, version,
converter), and to sequence them dynamically instead of
statically. *)
let upgradable_data_version = []
let store_dir data_dir = data_dir // "store"
let context_dir data_dir = data_dir // "context"
let protocol_dir data_dir = data_dir // "protocol"
let lock_file data_dir = data_dir // "lock"
let default_identity_file_name = "identity.json"
let default_peers_file_name = "peers.json"
let default_config_file_name = "config.json"
let version_file_name = "version.json"
let version_encoding = Data_encoding.(obj1 (req "version" string))
type error += Invalid_data_dir_version of t * t
type error += Invalid_data_dir of string
type error += Could_not_read_data_dir_version of string
type error += Data_dir_needs_upgrade of {expected : t; actual : t}
let () =
register_error_kind
`Permanent
~id:"invalidDataDir"
~title:"Invalid data directory"
~description:"The data directory cannot be accessed or created"
~pp:(fun ppf path ->
Format.fprintf ppf "Invalid data directory '%s'." path)
Data_encoding.(obj1 (req "datadir_path" string))
(function Invalid_data_dir path -> Some path | _ -> None)
(fun path -> Invalid_data_dir path) ;
register_error_kind
`Permanent
~id:"invalidDataDirVersion"
~title:"Invalid data directory version"
~description:"The data directory version was not the one that was expected"
~pp:(fun ppf (exp, got) ->
Format.fprintf
ppf
"Invalid data directory version '%s' (expected '%s')."
got
exp)
Data_encoding.(
obj2 (req "expected_version" string) (req "actual_version" string))
(function
| Invalid_data_dir_version (expected, actual) ->
Some (expected, actual)
| _ ->
None)
(fun (expected, actual) -> Invalid_data_dir_version (expected, actual)) ;
register_error_kind
`Permanent
~id:"couldNotReadDataDirVersion"
~title:"Could not read data directory version file"
~description:"Data directory version file was invalid."
Data_encoding.(obj1 (req "version_path" string))
~pp:(fun ppf path ->
Format.fprintf
ppf
"Tried to read version file at '%s', but the file could not be parsed."
path)
(function Could_not_read_data_dir_version path -> Some path | _ -> None)
(fun path -> Could_not_read_data_dir_version path) ;
register_error_kind
`Permanent
~id:"dataDirNeedsUpgrade"
~title:"The data directory needs to be upgraded"
~description:"The data directory needs to be upgraded"
~pp:(fun ppf (exp, got) ->
Format.fprintf
ppf
"The data directory version is too old.@,\
Found '%s', expected '%s'.@,\
It needs to be upgraded with `tezos-node upgrade_storage`."
got
exp)
Data_encoding.(
obj2 (req "expected_version" string) (req "actual_version" string))
(function
| Data_dir_needs_upgrade {expected; actual} ->
Some (expected, actual)
| _ ->
None)
(fun (expected, actual) -> Data_dir_needs_upgrade {expected; actual})
let version_file data_dir = Filename.concat data_dir version_file_name
let clean_directory files =
let to_delete =
Format.asprintf
"@[<v>%a@]"
(Format.pp_print_list ~pp_sep:Format.pp_print_cut Format.pp_print_string)
files
in
Format.sprintf "Please provide a clean directory by removing:@ %s" to_delete
let write_version data_dir =
Lwt_utils_unix.Json.write_file
(version_file data_dir)
(Data_encoding.Json.construct version_encoding data_version)
let check_data_dir_version files data_dir =
let version_file = version_file data_dir in
Lwt_unix.file_exists version_file
>>= function
| false ->
fail (Invalid_data_dir (clean_directory files))
| true -> (
Lwt_utils_unix.Json.read_file version_file
|> trace (Could_not_read_data_dir_version version_file)
>>=? fun json ->
( try return (Data_encoding.Json.destruct version_encoding json)
with
| Data_encoding.Json.Cannot_destruct _
| Data_encoding.Json.Unexpected _
| Data_encoding.Json.No_case_matched _
| Data_encoding.Json.Bad_array_size _
| Data_encoding.Json.Missing_field _
| Data_encoding.Json.Unexpected_field _
->
fail (Could_not_read_data_dir_version version_file) )
>>=? fun version ->
if String.equal version data_version then return_none
else
match
List.find_opt
(fun (v, _) -> String.equal v version)
upgradable_data_version
with
| Some f ->
return_some f
| None ->
fail (Invalid_data_dir_version (data_version, version)) )
let ensure_data_dir bare data_dir =
let write_version () = write_version data_dir >>=? fun () -> return_none in
Lwt.catch
(fun () ->
Lwt_unix.file_exists data_dir
>>= function
| true -> (
Lwt_stream.to_list (Lwt_unix.files_of_directory data_dir)
>|= List.filter (fun s ->
s <> "." && s <> ".." && s <> version_file_name
&& s <> default_identity_file_name
&& s <> default_config_file_name
&& s <> default_peers_file_name)
>>= function
| [] ->
write_version ()
| files when bare ->
fail (Invalid_data_dir (clean_directory files))
| files ->
check_data_dir_version files data_dir )
| false ->
Lwt_utils_unix.create_dir ~perm:0o700 data_dir
>>= fun () -> write_version ())
(function
| Unix.Unix_error _ ->
fail (Invalid_data_dir data_dir)
| exc ->
raise exc)
let ensure_data_dir ?(bare = false) data_dir =
ensure_data_dir bare data_dir
>>=? function
| None ->
return_unit
| Some (version, _) ->
fail (Data_dir_needs_upgrade {expected = data_version; actual = version})
src/bin_node/node_data_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition t := string.
Definition data_version : string := "0.0.4" % string.
Definition upgradable_data_version {A : Type} : list A := [].
Definition store_dir (data_dir : string) : string :=
op_divdiv data_dir "store" % string.
Definition context_dir (data_dir : string) : string :=
op_divdiv data_dir "context" % string.
Definition protocol_dir (data_dir : string) : string :=
op_divdiv data_dir "protocol" % string.
Definition lock_file (data_dir : string) : string :=
op_divdiv data_dir "lock" % string.
Definition default_identity_file_name : string := "identity.json" % string.
Definition default_peers_file_name : string := "peers.json" % string.
Definition default_config_file_name : string := "config.json" % string.
Definition version_file_name : string := "version.json" % string.
Definition version_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding string :=
obj1 (req None None "version" % string string).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition version_file (data_dir : string) : string :=
Filename.concat data_dir version_file_name.
Definition clean_directory (files : list string) : string :=
let to_delete :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v>" % string
CamlinternalFormatBasics.End_of_format) "<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[<v>%a@]" % string)
(Format.pp_print_list (Some Format.pp_print_cut) Format.pp_print_string)
files in
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Please provide a clean directory by removing:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"Please provide a clean directory by removing:@ %s" % string) to_delete.
Definition write_version (data_dir : string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
Lwt_utils_unix.Json.write_file (version_file data_dir)
(Data_encoding.Json.construct version_encoding data_version).
Definition check_data_dir_version {A : Type}
(files : list string) (data_dir : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.String.t * A))) :=
let version_file := version_file data_dir in
op_gtgteq (Lwt_unix.file_exists version_file)
(fun function_parameter =>
match function_parameter with
| false =>
fail (Tezos_base__TzPervasives.Invalid_data_dir (clean_directory files))
| true =>
op_gtgteqquestion
(OCaml.Stdlib.reverse_apply
(Lwt_utils_unix.Json.read_file version_file)
(trace
(Tezos_base__TzPervasives.Could_not_read_data_dir_version
version_file)))
(fun json =>
op_gtgteqquestion
(* ❌ Try-with are not handled *)
(try (_return (Data_encoding.Json.destruct version_encoding json)))
(fun version =>
if String.equal version data_version then
return_none
else
match
List.find_opt
(fun function_parameter =>
let '(v, _) := function_parameter in
String.equal v version) upgradable_data_version with
| Some f => return_some f
| None =>
fail
(Tezos_base__TzPervasives.Invalid_data_dir_version
data_version version)
end))
end).
Definition ensure_data_dir {A : Type} (bare : bool) (data_dir : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.String.t * A))) :=
let write_version {B : Type} (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult (option B)) :=
let 'tt := function_parameter in
op_gtgteqquestion (write_version data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
return_none) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.file_exists data_dir)
(fun function_parameter =>
match function_parameter with
| true =>
op_gtgteq
(op_gtpipeeq
(Lwt_stream.to_list (Lwt_unix.files_of_directory data_dir))
(List.filter
(fun s =>
andb (nequiv_decb s "." % string)
(andb (nequiv_decb s ".." % string)
(andb (nequiv_decb s version_file_name)
(andb (nequiv_decb s default_identity_file_name)
(andb (nequiv_decb s default_config_file_name)
(nequiv_decb s default_peers_file_name))))))))
(fun function_parameter =>
match function_parameter with
| [] => write_version tt
| files =>
fail
(Tezos_base__TzPervasives.Invalid_data_dir
(clean_directory files))
| files => check_data_dir_version files data_dir
end)
| false =>
op_gtgteq (Lwt_utils_unix.create_dir (Some 448) data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
write_version tt)
end))
(fun function_parameter =>
match function_parameter with
| Unix_error _ _ _ =>
fail (Tezos_base__TzPervasives.Invalid_data_dir data_dir)
| exc => Stdlib.raise exc
end).
Definition ensure_data_dir (op_staroptstar : option bool)
: string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let bare :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun data_dir =>
op_gtgteqquestion (ensure_data_dir bare data_dir)
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (version, _) =>
fail
(Tezos_base__TzPervasives.Data_dir_needs_upgrade
{| expected := data_version; actual := version |})
end).
src/bin_node/node_identity_command.ml 21 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
(** Commands *)
let identity_file data_dir =
data_dir // Node_data_version.default_identity_file_name
let show {Node_config_file.data_dir; _} =
Node_identity_file.read (identity_file data_dir)
>>=? fun id ->
Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ;
return_unit
let generate_with_animation ppf target =
let duration = 1200 / Animation.number_of_frames in
Animation.make_with_animation
ppf
~make:(fun count ->
try Ok (P2p_identity.generate_with_bound ~max:count target)
with Not_found -> Error count)
~on_retry:(fun time count ->
let ms = int_of_float (Mtime.Span.to_ms time) in
if ms <= 1 then max 10 (count * 10) else count * duration / ms)
10000
let generate {Node_config_file.data_dir; p2p; _} =
let identity_file = identity_file data_dir in
if Sys.file_exists identity_file then
fail (Node_identity_file.Existent_identity_file identity_file)
else
let target = Crypto_box.make_target p2p.expected_pow in
Format.eprintf
"Generating a new identity... (level: %.2f) "
p2p.expected_pow ;
let id = generate_with_animation Format.err_formatter target in
Node_identity_file.write identity_file id
>>=? fun () ->
Format.eprintf
"Stored the new identity (%a) into '%s'.@."
P2p_peer.Id.pp
id.peer_id
identity_file ;
return_unit
let check {Node_config_file.data_dir; p2p = {expected_pow; _}; _} =
Node_identity_file.read ~expected_pow (identity_file data_dir)
>>=? fun id ->
Format.printf
"Peer_id: %a. Proof of work is higher than %.2f.@."
P2p_peer.Id.pp
id.peer_id
expected_pow ;
return_unit
(** Main *)
module Term = struct
type subcommand = Show | Generate | Check
let process subcommand data_dir config_file expected_pow =
let res =
( match (data_dir, config_file) with
| (None, None) ->
let default_config =
Node_config_file.default_data_dir
// Node_data_version.default_config_file_name
in
if Sys.file_exists default_config then
Node_config_file.read default_config
else return Node_config_file.default_config
| (None, Some config_file) ->
Node_config_file.read config_file
| (Some data_dir, None) ->
Node_config_file.read
(data_dir // Node_data_version.default_config_file_name)
>>=? fun cfg -> return {cfg with data_dir}
| (Some data_dir, Some config_file) ->
Node_config_file.read config_file
>>=? fun cfg -> return {cfg with data_dir} )
>>=? fun cfg ->
Node_config_file.update ?expected_pow cfg
>>=? fun cfg ->
match subcommand with
| Show ->
show cfg
| Generate ->
generate cfg
| Check ->
check cfg
in
match Lwt_main.run res with
| Ok () ->
`Ok ()
| Error err ->
`Error (false, Format.asprintf "%a" pp_print_error err)
let subcommand_arg =
let parser = function
| "show" ->
`Ok Show
| "generate" ->
`Ok Generate
| "check" ->
`Ok Check
| s ->
`Error ("invalid argument: " ^ s)
and printer fmt = function
| Show ->
Format.fprintf fmt "show"
| Generate ->
Format.fprintf fmt "generate"
| Check ->
Format.fprintf fmt "check"
in
let doc =
"Operation to perform. Possible values: $(b,show), $(b,generate), \
$(b,check)."
in
let open Cmdliner.Arg in
value & pos 0 (parser, printer) Show & info [] ~docv:"OPERATION" ~doc
let expected_pow =
let open Cmdliner in
let doc =
"Expected amount of proof-of-work for the node identity. The optional \
parameter should be a float between 0 and 256, where\n\
\ 0 disables the proof-of-work mechanism."
in
Arg.(value & pos 1 (some float) None & info [] ~docv:"DIFFICULTY" ~doc)
let term =
Cmdliner.Term.(
ret
( const process $ subcommand_arg $ Node_shared_arg.Term.data_dir
$ Node_shared_arg.Term.config_file $ expected_pow ))
end
module Manpage = struct
let command_description =
"The $(b,identity) command is meant to create and manage node identities. \
An $(i,identity) uniquely identifies a peer on the network and consists \
of a cryptographic key pair as well as a proof-of-work stamp that \
certifies that enough CPU time has been dedicated to produce the \
identity, to avoid sybil attacks. An identity with enough proof-of-work \
is required to participate in the Tezos network, therefore this command \
is necessary to launch Tezos the first time."
let description =
[ `S "DESCRIPTION";
`P (command_description ^ " Several options are possible:");
`P
"$(b,show) reads, parses and displays the current identity of the \
node. Use this command to see what identity will be used by Tezos. \
This is the default operation.";
`P
"$(b,generate [difficulty]) generates an identity whose proof of work \
stamp difficulty is at least equal to $(i,difficulty). The value \
provided must be a floating point number between 0 and 256. It \
roughly reflects the numbers of expected leading zeroes in the hash \
of the identity data-structure. Therefore, a value of 0 means no \
proof-of-work, and the difficulty doubles for each increment of 1 in \
the difficulty value.";
`P
"$(b,check [difficulty]) checks that an identity is valid and that \
its proof of work stamp difficulty is at least equal to \
$(i,difficulty)." ]
let man = description @ (* [ `S misc_docs ] @ *)
Node_shared_arg.Manpage.bugs
let info = Cmdliner.Term.info ~doc:"Manage node identities" ~man "identity"
end
let cmd = (Term.term, Manpage.info)
src/bin_node/node_identity_command.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition identity_file (data_dir : string) : string :=
op_divdiv data_dir Node_data_version.default_identity_file_name.
Definition show (function_parameter : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{| Node_config_file.data_dir := data_dir |} := function_parameter in
op_gtgteqquestion (Node_identity_file.read None (identity_file data_dir))
(fun id =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Peer_id: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Peer_id: %a.@." % string) P2p_peer.Id.pp (peer_id id) in
return_unit).
Definition generate_with_animation
(ppf : Stdlib.Format.formatter) (target : Tezos_crypto.Crypto_box.target)
: Tezos_base__TzPervasives.P2p_identity.t :=
let duration := Z.div 1200 Animation.number_of_frames in
Animation.make_with_animation ppf
(fun count =>
(* ❌ Try-with are not handled *)
try (Stdlib.Ok (P2p_identity.generate_with_bound (Some count) target)))
(fun time =>
fun count =>
let ms := Stdlib.int_of_float (Mtime.Span.to_ms time) in
if OCaml.Stdlib.le ms 1 then
OCaml.Stdlib.max 10 (Z.mul count 10)
else
Z.div (Z.mul count duration) ms) 10000.
Definition generate (function_parameter : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
Node_config_file.data_dir := data_dir; Node_config_file.p2p := p2p |} :=
function_parameter in
let identity_file := identity_file data_dir in
if Sys.file_exists identity_file then
fail (Tezos_base__TzPervasives.Existent_identity_file identity_file)
else
let target := Crypto_box.make_target (expected_pow p2p) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Generating a new identity... (level: " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal ") " % string
CamlinternalFormatBasics.End_of_format)))
"Generating a new identity... (level: %.2f) " % string)
(expected_pow p2p) in
let id := generate_with_animation Format.err_formatter target in
op_gtgteqquestion (Node_identity_file.write identity_file id)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Stored the new identity (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ") into '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "'." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Stored the new identity (%a) into '%s'.@." % string)
P2p_peer.Id.pp (peer_id id) identity_file in
return_unit).
Definition check (function_parameter : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
Node_config_file.data_dir := data_dir;
Node_config_file.p2p := {| expected_pow := expected_pow |}
|} := function_parameter in
op_gtgteqquestion
(Node_identity_file.read (Some expected_pow) (identity_file data_dir))
(fun id =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Peer_id: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
". Proof of work is higher than " % string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Peer_id: %a. Proof of work is higher than %.2f.@." % string)
P2p_peer.Id.pp (peer_id id) expected_pow in
return_unit).
Module Term.
Inductive subcommand : Type :=
| Show : subcommand
| Generate : subcommand
| Check : subcommand.
Definition process
(subcommand : subcommand) (data_dir : option string)
(config_file : option string) (expected_pow : option Z) : variant :=
let res :=
op_gtgteqquestion
match (data_dir, config_file) with
| (None, None) =>
let default_config :=
op_divdiv Node_config_file.default_data_dir
Node_data_version.default_config_file_name in
if Sys.file_exists default_config then
Node_config_file.read default_config
else
_return Node_config_file.default_config
| (None, Some config_file) => Node_config_file.read config_file
| (Some data_dir, None) =>
op_gtgteqquestion
(Node_config_file.read
(op_divdiv data_dir Node_data_version.default_config_file_name))
(fun cfg =>
_return
(* ❌ Record substitution not handled *)
record_substitution)
| (Some data_dir, Some config_file) =>
op_gtgteqquestion (Node_config_file.read config_file)
(fun cfg =>
_return
(* ❌ Record substitution not handled *)
record_substitution)
end
(fun cfg =>
op_gtgteqquestion
(Node_config_file.update None None None None None None None None
expected_pow None None None None None None None None None None
None None None cfg)
(fun cfg =>
match subcommand with
| Show => show cfg
| Generate => generate cfg
| Check => check cfg
end)) in
match Lwt_main.run res with
| Stdlib.Ok tt =>
(* ❌ Variants not supported *)
variant
| Stdlib.Error err =>
(* ❌ Variants not supported *)
variant
end.
Definition subcommand_arg : Cmdliner.Term.t subcommand :=
let parser (function_parameter : string) : variant :=
match function_parameter with
| "show" % string =>
(* ❌ Variants not supported *)
variant
| "generate" % string =>
(* ❌ Variants not supported *)
variant
| "check" % string =>
(* ❌ Variants not supported *)
variant
| s =>
(* ❌ Variants not supported *)
variant
end
with printer
(fmt : Stdlib.Format.formatter) (function_parameter : subcommand)
: unit :=
match function_parameter with
| Show =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "show" % string
CamlinternalFormatBasics.End_of_format) "show" % string)
| Generate =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "generate" % string
CamlinternalFormatBasics.End_of_format) "generate" % string)
| Check =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "check" % string
CamlinternalFormatBasics.End_of_format) "check" % string)
end in
let doc :=
"Operation to perform. Possible values: $(b,show), $(b,generate), $(b,check)."
% string in
op_and value
(op_and (pos None 0 (parser, printer) Show)
(info None (Some "OPERATION" % string) (Some doc) None [])).
Definition expected_pow : Cmdliner.Term.t (option Z) :=
let doc :=
"Expected amount of proof-of-work for the node identity. The optional parameter should be a float between 0 and 256, where
0 disables the proof-of-work mechanism."
% string in
op_and value
(op_and (pos None 1 (some None float) None)
(info None (Some "DIFFICULTY" % string) (Some doc) None [])).
Definition term : Cmdliner.Term.t unit :=
ret
(op_dollar
(op_dollar
(op_dollar (op_dollar (const process) subcommand_arg)
Node_shared_arg.Term.data_dir) Node_shared_arg.Term.config_file)
expected_pow).
End Term.
Module Manpage.
Definition command_description : string :=
"The $(b,identity) command is meant to create and manage node identities. An $(i,identity) uniquely identifies a peer on the network and consists of a cryptographic key pair as well as a proof-of-work stamp that certifies that enough CPU time has been dedicated to produce the identity, to avoid sybil attacks. An identity with enough proof-of-work is required to participate in the Tezos network, therefore this command is necessary to launch Tezos the first time."
% string.
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])))).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description Node_shared_arg.Manpage.bugs.
Definition info : Cmdliner.Term.info :=
Cmdliner.Term.info None (Some man) None None None None
(Some "Manage node identities" % string) None "identity" % string.
End Manpage.
Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
(Term.term, Manpage.info).
src/bin_node/node_identity_file.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type error += No_identity_file of string
type error += Insufficient_proof_of_work of {expected : float}
type error +=
| Identity_mismatch of {
filename : string;
peer_id : Crypto_box.Public_key_hash.t;
}
type error +=
| Identity_keys_mismatch of {
filename : string;
expected_key : Crypto_box.public_key;
}
let () =
register_error_kind
`Permanent
~id:"main.identity.no_file"
~title:"No identity file"
~description:"The node identity file cannot be found"
~pp:(fun ppf file ->
Format.fprintf
ppf
"Cannot read the identity file: `%s`. See `%s identity --help` on how \
to generate an identity."
file
Sys.argv.(0))
Data_encoding.(obj1 (req "file" string))
(function No_identity_file file -> Some file | _ -> None)
(fun file -> No_identity_file file)
let () =
register_error_kind
`Permanent
~id:"main.identity.insufficient_proof_of_work"
~title:"Insufficient proof of work"
~description:
"The proof of work embeded by the current identity is not sufficient"
~pp:(fun ppf expected ->
Format.fprintf
ppf
"The current identity does not embed a sufficient stamp of \
proof-of-work. (expected level: %.2f). See `%s identity --help` on \
how to generate a new identity."
expected
Sys.argv.(0))
Data_encoding.(obj1 (req "expected" float))
(function
| Insufficient_proof_of_work {expected} -> Some expected | _ -> None)
(fun expected -> Insufficient_proof_of_work {expected})
let () =
register_error_kind
`Permanent
~id:"main.identity.identity_mismatch"
~title:"Identity mismatch"
~description:
"The identity (public key hash) does not match the keys provided with it"
~pp:(fun ppf (file, public_key_hash) ->
Format.fprintf
ppf
"The current identity (public key hash) does not match the keys in %s.\n\
\ Expected identity %a."
file
Crypto_box.Public_key_hash.pp
public_key_hash)
Data_encoding.(
obj2
(req "file" string)
(req "public_key_hash" Crypto_box.Public_key_hash.encoding))
(function
| Identity_mismatch {filename; peer_id} ->
Some (filename, peer_id)
| _ ->
None)
(fun (filename, peer_id) -> Identity_mismatch {filename; peer_id})
let () =
register_error_kind
`Permanent
~id:"main.identity.identity_keys_mismatch"
~title:"Identity keys mismatch"
~description:
"The current identity file has non-matching keys (secret key/ public \
key pair is not valid)"
~pp:(fun ppf (file, public_key) ->
Format.fprintf
ppf
"The current identity file %s has non-matching keys (secret key/ \
public key pair is not valid).\n\
\ Expected public key %a."
file
Crypto_box.pp_pk
public_key)
Data_encoding.(
obj2
(req "file" string)
(req "public_key" Crypto_box.public_key_encoding))
(function
| Identity_keys_mismatch {filename; expected_key} ->
Some (filename, expected_key)
| _ ->
None)
(fun (filename, expected_key) ->
Identity_keys_mismatch {filename; expected_key})
let read ?expected_pow filename =
Lwt_unix.file_exists filename
>>= function
| false ->
fail (No_identity_file filename)
| true -> (
Lwt_utils_unix.Json.read_file filename
>>=? fun json ->
let id = Data_encoding.Json.destruct P2p_identity.encoding json in
let pkh = Crypto_box.hash id.public_key in
(* check public_key hash *)
if not (Crypto_box.Public_key_hash.equal pkh id.peer_id) then
fail (Identity_mismatch {filename; peer_id = pkh})
(* check public/private keys correspondance *)
else if not Crypto_box.(equal (neuterize id.secret_key) id.public_key)
then
fail (Identity_keys_mismatch {filename; expected_key = id.public_key})
else
(* check PoW level *)
match expected_pow with
| None ->
return id
| Some expected ->
let target = Crypto_box.make_target expected in
if
not
(Crypto_box.check_proof_of_work
id.public_key
id.proof_of_work_stamp
target)
then fail (Insufficient_proof_of_work {expected})
else return id )
type error += Existent_identity_file of string
let () =
register_error_kind
`Permanent
~id:"main.identity.existent_file"
~title:"Cannot overwrite identity file"
~description:"Cannot implicitely overwrite the current identity file"
~pp:(fun ppf file ->
Format.fprintf
ppf
"Cannot implicitely overwrite the current identity file: '%s'. See \
`%s identity --help` on how to generate a new identity."
file
Sys.argv.(0))
Data_encoding.(obj1 (req "file" string))
(function Existent_identity_file file -> Some file | _ -> None)
(fun file -> Existent_identity_file file)
let write file identity =
if Sys.file_exists file then fail (Existent_identity_file file)
else
Node_data_version.ensure_data_dir (Filename.dirname file)
>>=? fun () ->
Lwt_utils_unix.Json.write_file
file
(Data_encoding.Json.construct P2p_identity.encoding identity)
src/bin_node/node_identity_file.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition read (expected_pow : option Z) (filename : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.P2p_identity.t) :=
op_gtgteq (Lwt_unix.file_exists filename)
(fun function_parameter =>
match function_parameter with
| false => fail (Tezos_base__TzPervasives.No_identity_file filename)
| true =>
op_gtgteqquestion (Lwt_utils_unix.Json.read_file filename)
(fun json =>
let id := Data_encoding.Json.destruct P2p_identity.encoding json in
let pkh := Crypto_box.hash (public_key id) in
if negb (Crypto_box.Public_key_hash.equal pkh (peer_id id)) then
fail
(Tezos_base__TzPervasives.Identity_mismatch
{| filename := filename; peer_id := pkh |})
else
if negb (equal (neuterize (secret_key id)) (public_key id)) then
fail
(Tezos_base__TzPervasives.Identity_keys_mismatch
{| filename := filename; expected_key := public_key id |})
else
match expected_pow with
| None => _return id
| Some expected =>
let target := Crypto_box.make_target expected in
if
negb
(Crypto_box.check_proof_of_work (public_key id)
(proof_of_work_stamp id) target) then
fail
(Tezos_base__TzPervasives.Insufficient_proof_of_work
{| expected := expected |})
else
_return id
end)
end).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition write
(file : string) (identity : Tezos_base__TzPervasives.P2p_identity.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if Sys.file_exists file then
fail (Tezos_base__TzPervasives.Existent_identity_file file)
else
op_gtgteqquestion
(Node_data_version.ensure_data_dir None (Filename.dirname file))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.Json.write_file file
(Data_encoding.Json.construct P2p_identity.encoding identity)).
src/bin_node/node_logging.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Internal_event.Legacy_logging.Make (struct let name = "node.main" end)
src/bin_node/node_logging.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/bin_node/node_run_command.ml 25 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Node_logging
open Genesis_chain
type error += Non_private_sandbox of P2p_addr.t
type error += RPC_Port_already_in_use of P2p_point.Id.t list
let () =
register_error_kind
`Permanent
~id:"main.run.non_private_sandbox"
~title:"Forbidden public sandbox"
~description:"A sandboxed node should not listen on a public address."
~pp:(fun ppf addr ->
Format.fprintf
ppf
"The node is configured to listen on a public address (%a), while \
only 'private' networks are authorised with `--sandbox`.\n\
\ See `%s run --help` on how to change the listening address."
Ipaddr.V6.pp
addr
Sys.argv.(0))
Data_encoding.(obj1 (req "addr" P2p_addr.encoding))
(function Non_private_sandbox addr -> Some addr | _ -> None)
(fun addr -> Non_private_sandbox addr) ;
register_error_kind
`Permanent
~id:"main.run.port_already_in_use"
~title:"Cannot start node: RPC port already in use"
~description:"Another tezos node is probably running on the same RPC port."
~pp:(fun ppf addrlist ->
Format.fprintf
ppf
"Another tezos node is probably running on one of these addresses \
(%a). Please choose another RPC port."
(Format.pp_print_list P2p_point.Id.pp)
addrlist)
Data_encoding.(obj1 (req "addrlist" (list P2p_point.Id.encoding)))
(function RPC_Port_already_in_use addrlist -> Some addrlist | _ -> None)
(fun addrlist -> RPC_Port_already_in_use addrlist)
let ( // ) = Filename.concat
let init_node ?sandbox ?checkpoint ~singleprocess (config : Node_config_file.t)
=
( match sandbox with
| None ->
Lwt.return_none
| Some sandbox_param -> (
match sandbox_param with
| None ->
Lwt.return_none
| Some file -> (
Lwt_utils_unix.Json.read_file file
>>= function
| Error err ->
lwt_warn "Cannot parse sandbox parameters: %s" file
>>= fun () ->
lwt_debug "%a" pp_print_error err >>= fun () -> Lwt.return_none
| Ok json ->
Lwt.return_some json ) ) )
>>= fun sandbox_param ->
(* TODO "WARN" when pow is below our expectation. *)
( match config.p2p.discovery_addr with
| None ->
lwt_log_notice "No local peer discovery."
>>= fun () -> return (None, None)
| Some addr -> (
Node_config_file.resolve_discovery_addrs addr
>>= function
| [] ->
failwith "Cannot resolve P2P discovery address: %S" addr
| (addr, port) :: _ ->
return (Some addr, Some port) ) )
>>=? fun (discovery_addr, discovery_port) ->
( match config.p2p.listen_addr with
| None ->
lwt_log_notice "Not listening to P2P calls."
>>= fun () -> return (None, None)
| Some addr -> (
Node_config_file.resolve_listening_addrs addr
>>= function
| [] ->
failwith "Cannot resolve P2P listening address: %S" addr
| (addr, port) :: _ ->
return (Some addr, Some port) ) )
>>=? fun (listening_addr, listening_port) ->
( match (listening_addr, sandbox) with
| (Some addr, Some _) when Ipaddr.V6.(compare addr unspecified) = 0 ->
return_none
| (Some addr, Some _) when not (Ipaddr.V6.is_private addr) ->
fail (Non_private_sandbox addr)
| (None, Some _) ->
return_none
| _ ->
Node_config_file.resolve_bootstrap_addrs config.p2p.bootstrap_peers
>>= fun trusted_points ->
Node_identity_file.read
(config.data_dir // Node_data_version.default_identity_file_name)
>>=? fun identity ->
lwt_log_notice "Peer's global id: %a" P2p_peer.Id.pp identity.peer_id
>>= fun () ->
let p2p_config : P2p.config =
{
listening_addr;
listening_port;
discovery_addr;
discovery_port;
trusted_points;
peers_file =
config.data_dir // Node_data_version.default_peers_file_name;
private_mode = config.p2p.private_mode;
greylisting_config = config.p2p.greylisting_config;
identity;
proof_of_work_target = Crypto_box.make_target config.p2p.expected_pow;
disable_mempool = config.p2p.disable_mempool;
trust_discovered_peers = sandbox_param <> None;
disable_testchain = config.p2p.disable_testchain;
}
in
return_some (p2p_config, config.p2p.limits) )
>>=? fun p2p_config ->
let sandbox_parameters = sandbox_param in
let sandbox_param =
Option.map ~f:(fun p -> ("sandbox_parameter", p)) sandbox_param
in
let node_config : Node.config =
{
genesis;
patch_context = Some (Patch_context.patch_context sandbox_param);
store_root = Node_data_version.store_dir config.data_dir;
context_root = Node_data_version.context_dir config.data_dir;
protocol_root = Node_data_version.protocol_dir config.data_dir;
p2p = p2p_config;
checkpoint;
}
in
Node.create
~sandboxed:(sandbox <> None)
?sandbox_parameters
~singleprocess
node_config
config.shell.peer_validator_limits
config.shell.block_validator_limits
config.shell.prevalidator_limits
config.shell.chain_validator_limits
config.shell.history_mode
(* Add default accepted CORS headers *)
let sanitize_cors_headers ~default headers =
List.map String.lowercase_ascii headers
|> String.Set.of_list
|> String.Set.(union (of_list default))
|> String.Set.elements
let launch_rpc_server (rpc_config : Node_config_file.rpc) node (addr, port) =
let host = Ipaddr.V6.to_string addr in
let dir = Node.build_rpc_directory node in
let mode =
match rpc_config.tls with
| None ->
`TCP (`Port port)
| Some {cert; key} ->
`TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
in
lwt_log_notice
"Starting a RPC server listening on %s:%d%s."
host
port
(if rpc_config.tls = None then "" else " (TLS enabled)")
>>= fun () ->
let cors_headers =
sanitize_cors_headers ~default:["Content-Type"] rpc_config.cors_headers
in
Lwt.catch
(fun () ->
RPC_server.launch
~host
mode
dir
~media_types:Media_type.all_media_types
~cors:
{
allowed_origins = rpc_config.cors_origins;
allowed_headers = cors_headers;
}
>>= return)
(function
| Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
fail (RPC_Port_already_in_use [(addr, port)])
| exn ->
Lwt.return (error_exn exn))
let init_rpc (rpc_config : Node_config_file.rpc) node =
fold_right_s
(fun addr acc ->
Node_config_file.resolve_rpc_listening_addrs addr
>>= function
| [] ->
failwith "Cannot resolve listening address: %S" addr
| addrs ->
fold_right_s
(fun x a ->
launch_rpc_server rpc_config node x >>=? fun o -> return (o :: a))
addrs
acc)
rpc_config.listen_addrs
[]
let run ?verbosity ?sandbox ?checkpoint ~singleprocess
(config : Node_config_file.t) =
Node_data_version.ensure_data_dir config.data_dir
>>=? fun () ->
Lwt_lock_file.create
~unlink_on_exit:true
(Node_data_version.lock_file config.data_dir)
>>=? fun () ->
(* Main loop *)
let log_cfg =
match verbosity with
| None ->
config.log
| Some default_level ->
{config.log with default_level}
in
Internal_event_unix.init
~lwt_log_sink:log_cfg
~configuration:config.internal_events
()
>>= fun () ->
Updater.init (Node_data_version.protocol_dir config.data_dir) ;
lwt_log_notice "Starting the Tezos node..."
>>= fun () ->
init_node ?sandbox ?checkpoint ~singleprocess config
>>= (function
| Ok node ->
return node
| Error
(State.Incorrect_history_mode_switch {previous_mode; next_mode}
:: _) ->
failwith
"@[Cannot switch from history mode '%a' to '%a'. Import a \
context from a corresponding snapshot or re-synchronize a node \
with an empty tezos node directory.@]"
History_mode.pp
previous_mode
History_mode.pp
next_mode
| Error _ as err ->
Lwt.return err)
>>=? fun node ->
init_rpc config.rpc node
>>=? fun rpc ->
lwt_log_notice "The Tezos node is now running!"
>>= fun () ->
Lwt_exit.(
wrap_promise @@ retcode_of_unit_result_lwt @@ Lwt_utils.never_ending ())
>>= fun retcode ->
(* Clean-shutdown code *)
Lwt_exit.termination_thread
>>= fun x ->
lwt_log_notice "Shutting down the Tezos node..."
>>= fun () ->
Node.shutdown node
>>= fun () ->
lwt_log_notice "Shutting down the RPC server..."
>>= fun () ->
Lwt_list.iter_p RPC_server.shutdown rpc
>>= fun () ->
lwt_log_notice "BYE (%d)" x
>>= fun () -> Internal_event_unix.close () >>= fun () -> return retcode
let process sandbox verbosity checkpoint singleprocess args =
let verbosity =
let open Internal_event in
match verbosity with [] -> None | [_] -> Some Info | _ -> Some Debug
in
let run =
Node_shared_arg.read_and_patch_config_file
~ignore_bootstrap_peers:
(match sandbox with Some _ -> true | None -> false)
args
>>=? fun config ->
( match sandbox with
| Some _ ->
if config.data_dir = Node_config_file.default_data_dir then
failwith "Cannot use default data directory while in sandbox mode"
else return_unit
| None ->
return_unit )
>>=? fun () ->
( match checkpoint with
| None ->
return_none
| Some s -> (
match Block_header.of_b58check s with
| Some b ->
return_some b
| None ->
failwith
"Failed to parse the provided checkpoint (Base58Check-encoded)." )
)
>>=? fun checkpoint ->
Lwt_lock_file.is_locked (Node_data_version.lock_file config.data_dir)
>>=? function
| false ->
Lwt.catch
(fun () -> run ?sandbox ?verbosity ?checkpoint ~singleprocess config)
(function
| Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
Lwt_list.fold_right_s
(fun addr acc ->
Node_config_file.resolve_rpc_listening_addrs addr
>>= fun x -> Lwt.return (x @ acc))
config.rpc.listen_addrs
[]
>>= fun addrlist -> fail (RPC_Port_already_in_use addrlist)
| exn ->
Lwt.return (error_exn exn))
| true ->
failwith "Data directory is locked by another process"
in
match Lwt_main.run run with
| Ok (0 | 2) ->
(* 2 means that we exit by a signal that was handled *)
`Ok ()
| Ok _ ->
`Error (false, "")
| Error err ->
`Error (false, Format.asprintf "%a" pp_print_error err)
module Term = struct
let verbosity =
let open Cmdliner in
let doc =
"Increase log level. Using $(b,-v) is equivalent to using \
$(b,TEZOS_LOG='*Â ->Â info'), and $(b,-vv) is equivalent to using \
$(b,TEZOS_LOG='*Â ->Â debug')."
in
Arg.(
value & flag_all
& info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["v"])
let sandbox =
let open Cmdliner in
let doc =
"Run the daemon in sandbox mode. P2P to non-localhost addresses are \
disabled, and constants of the economic protocol can be altered with \
an optional JSON file. $(b,IMPORTANT): Using sandbox mode affects the \
node state and subsequent runs of Tezos node must also use sandbox \
mode. In order to run the node in normal mode afterwards, a full reset \
must be performed (by removing the node's data directory)."
in
Arg.(
value
& opt ~vopt:(Some None) (some (some string)) None
& info
~docs:Node_shared_arg.Manpage.misc_section
~doc
~docv:"FILE.json"
["sandbox"])
let checkpoint =
let open Cmdliner in
let doc =
"When asked to take a block hash as a checkpoint, the daemon will only \
accept the chains that contains that block and those that might reach \
it."
in
Arg.(
value
& opt (some string) None
& info
~docs:Node_shared_arg.Manpage.misc_section
~doc
~docv:"<level>,<block_hash>"
["checkpoint"])
let singleprocess =
let open Cmdliner in
let doc =
"When enabled, it deactivates block validation using an external \
process. Thus, the validation procedure is done in the same process as \
the node and might not be responding when doing extensive I/Os."
in
Arg.(
value & flag
& info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["singleprocess"])
let term =
Cmdliner.Term.(
ret
( const process $ sandbox $ verbosity $ checkpoint $ singleprocess
$ Node_shared_arg.Term.args ))
end
module Manpage = struct
let command_description =
"The $(b,run) command is meant to run the Tezos node. Most of its command \
line arguments corresponds to config file entries, and will have \
priority over the latter if used."
let description = [`S "DESCRIPTION"; `P command_description]
let debug =
let log_sections =
String.concat " " (List.rev !Internal_event.Legacy_logging.sections)
in
[ `S "DEBUG";
`P
( "The environment variable $(b,TEZOS_LOG) is used to fine-tune what \
is going to be logged. The syntax is \
$(b,TEZOS_LOG='<section>Â ->Â <level> [ ; ...]') where section is \
one of $(i," ^ log_sections
^ ") and level is one of $(i,fatal), $(i,error), $(i,warn), \
$(i,notice), $(i,info) or $(i,debug). A $(b,*) can be used as a \
wildcard in sections, i.e. $(b, client*Â ->Â debug). The rules are \
matched left to right, therefore the leftmost rule is highest \
priority ." ) ]
let examples =
[ `S "EXAMPLES";
`I
( "$(b,Run in sandbox mode listening to RPC commands at localhost \
port 8732)",
"$(mname) run --sandbox --data-dir /custom/data/dir --rpc-addr \
localhost:8732" );
`I ("$(b,Run a node that accepts network connections)", "$(mname) run")
]
let man =
description @ Node_shared_arg.Manpage.args @ debug @ examples
@ Node_shared_arg.Manpage.bugs
let info = Cmdliner.Term.info ~doc:"Run the Tezos node" ~man "run"
end
let cmd = (Term.term, Manpage.info)
src/bin_node/node_run_command.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Node_logging.
Import Genesis_chain.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition init_node
(sandbox : option (option string))
(checkpoint : option Tezos_base__TzPervasives.Block_header.t)
(singleprocess : bool) (config : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.Node.t) :=
op_gtgteq
match sandbox with
| None => Lwt.return_none
| Some sandbox_param =>
match sandbox_param with
| None => Lwt.return_none
| Some file =>
op_gtgteq (Lwt_utils_unix.Json.read_file file)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_warn)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot parse sandbox parameters: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot parse sandbox parameters: %s" % string) file)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_debug)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_none))
| Stdlib.Ok json => Lwt.return_some json
end)
end
end
(fun sandbox_param =>
op_gtgteqquestion
match discovery_addr (p2p config) with
| None =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No local peer discovery." % string
CamlinternalFormatBasics.End_of_format)
"No local peer discovery." % string))
(fun function_parameter =>
let 'tt := function_parameter in
_return (None, None))
| Some addr =>
op_gtgteq (Node_config_file.resolve_discovery_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve P2P discovery address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve P2P discovery address: %S" % string) addr
| cons (addr, port) _ => _return ((Some addr), (Some port))
end)
end
(fun function_parameter =>
let '(discovery_addr, discovery_port) := function_parameter in
op_gtgteqquestion
match listen_addr (p2p config) with
| None =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Not listening to P2P calls." % string
CamlinternalFormatBasics.End_of_format)
"Not listening to P2P calls." % string))
(fun function_parameter =>
let 'tt := function_parameter in
_return (None, None))
| Some addr =>
op_gtgteq (Node_config_file.resolve_listening_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve P2P listening address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve P2P listening address: %S" % string)
addr
| cons (addr, port) _ => _return ((Some addr), (Some port))
end)
end
(fun function_parameter =>
let '(listening_addr, listening_port) := function_parameter in
op_gtgteqquestion
match (listening_addr, sandbox) with
| (Some addr, Some _) => return_none
| (Some addr, Some _) =>
fail (Tezos_base__TzPervasives.Non_private_sandbox addr)
| (None, Some _) => return_none
| _ =>
op_gtgteq
(Node_config_file.resolve_bootstrap_addrs
(bootstrap_peers (p2p config)))
(fun trusted_points =>
op_gtgteqquestion
(Node_identity_file.read None
(op_divdiv (data_dir config)
Node_data_version.default_identity_file_name))
(fun identity =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Peer's global id: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Peer's global id: %a" % string) P2p_peer.Id.pp
(peer_id identity))
(fun function_parameter =>
let 'tt := function_parameter in
let p2p_config :=
{| listening_port := listening_port;
listening_addr := listening_addr;
discovery_port := discovery_port;
discovery_addr := discovery_addr;
trusted_points := trusted_points;
peers_file :=
op_divdiv (data_dir config)
Node_data_version.default_peers_file_name;
private_mode := private_mode (p2p config);
identity := identity;
proof_of_work_target :=
Crypto_box.make_target
(expected_pow (p2p config));
disable_mempool :=
disable_mempool (p2p config);
trust_discovered_peers :=
nequiv_decb sandbox_param None;
disable_testchain :=
disable_testchain (p2p config);
greylisting_config :=
greylisting_config (p2p config) |} in
return_some (p2p_config, (limits (p2p config))))))
end
(fun p2p_config =>
let sandbox_parameters := sandbox_param in
let sandbox_param :=
Option.map (fun p => ("sandbox_parameter" % string, p))
sandbox_param in
let node_config :=
{| genesis := genesis;
store_root :=
Node_data_version.store_dir (data_dir config);
context_root :=
Node_data_version.context_dir (data_dir config);
protocol_root :=
Node_data_version.protocol_dir (data_dir config);
patch_context :=
Some (Patch_context.patch_context sandbox_param);
p2p := p2p_config; checkpoint := checkpoint |} in
Node.create (Some (nequiv_decb sandbox None))
sandbox_parameters singleprocess node_config
(peer_validator_limits (shell config))
(block_validator_limits (shell config))
(prevalidator_limits (shell config))
(chain_validator_limits (shell config))
(history_mode (shell config)))))).
Definition sanitize_cors_headers
(default : list Tezos_base__TzPervasives.String.Set.elt)
(headers : list string) : list Tezos_base__TzPervasives.String.Set.elt :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (List.map String.lowercase_ascii headers)
String.Set.of_list) (union (of_list default))) String.Set.elements.
Definition launch_rpc_server
(rpc_config : Node_config_file.rpc) (node : Tezos_shell.Node.t)
(function_parameter : Ipaddr.V6.t * Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_rpc_http_server.RPC_server.server) :=
let '(addr, port) := function_parameter in
let host := Ipaddr.V6.to_string addr in
let dir := Node.build_rpc_directory node in
let mode :=
match tls rpc_config with
| None =>
(* ❌ Variants not supported *)
variant
| Some {| cert := cert; key := key |} =>
(* ❌ Variants not supported *)
variant
end in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Starting a RPC server listening on " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format))))))
"Starting a RPC server listening on %s:%d%s." % string) host port
(if equiv_decb (tls rpc_config) None then
"" % string
else
" (TLS enabled)" % string))
(fun function_parameter =>
let 'tt := function_parameter in
let cors_headers :=
sanitize_cors_headers (cons "Content-Type" % string [])
(cors_headers rpc_config) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(RPC_server.launch (Some host)
(Some
{| allowed_headers := cors_headers;
allowed_origins := cors_origins rpc_config |})
Media_type.all_media_types mode dir) _return)
(fun function_parameter =>
match function_parameter with
| Unix_error Unix.EADDRINUSE "bind" % string "" % string =>
fail
(Tezos_base__TzPervasives.RPC_Port_already_in_use
(cons (addr, port) []))
| exn => Lwt._return (error_exn exn)
end)).
Definition init_rpc
(rpc_config : Node_config_file.rpc) (node : Tezos_shell.Node.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_rpc_http_server.RPC_server.server)) :=
fold_right_s
(fun addr =>
fun acc =>
op_gtgteq (Node_config_file.resolve_rpc_listening_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve listening address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve listening address: %S" % string) addr
| addrs =>
fold_right_s
(fun x =>
fun a =>
op_gtgteqquestion (launch_rpc_server rpc_config node x)
(fun o => _return (cons o a))) addrs acc
end)) (listen_addrs rpc_config) [].
Definition run
(verbosity : option Tezos_event_logging.Internal_event.level)
(sandbox : option (option string))
(checkpoint : option Tezos_base__TzPervasives.Block_header.t)
(singleprocess : bool) (config : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
op_gtgteqquestion (Node_data_version.ensure_data_dir None (data_dir config))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt_lock_file.create None (Some true)
(Node_data_version.lock_file (data_dir config)))
(fun function_parameter =>
let 'tt := function_parameter in
let log_cfg :=
match verbosity with
| None => log config
| Some default_level =>
(* ❌ Record substitution not handled *)
record_substitution
end in
op_gtgteq
(Internal_event_unix.init (Some log_cfg)
(Some (internal_events config)) tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Updater.init (Node_data_version.protocol_dir (data_dir config))
in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Starting the Tezos node..." % string
CamlinternalFormatBasics.End_of_format)
"Starting the Tezos node..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteq
(init_node sandbox checkpoint singleprocess config)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok node => _return node
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Incorrect_history_mode_switch
{|
previous_mode := previous_mode;
next_mode := next_mode
|}) _) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"Cannot switch from history mode '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"' to '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"'. Import a context from a corresponding snapshot or re-synchronize a node with an empty tezos node directory."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[Cannot switch from history mode '%a' to '%a'. Import a context from a corresponding snapshot or re-synchronize a node with an empty tezos node directory.@]"
% string) History_mode.pp previous_mode
History_mode.pp next_mode
| (Stdlib.Error _) as err => Lwt._return err
end))
(fun node =>
op_gtgteqquestion (init_rpc (rpc config) node)
(fun rpc =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The Tezos node is now running!" % string
CamlinternalFormatBasics.End_of_format)
"The Tezos node is now running!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(apply wrap_promise
(apply retcode_of_unit_result_lwt
(Lwt_utils.never_ending tt)))
(fun retcode =>
op_gtgteq Lwt_exit.termination_thread
(fun x =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the Tezos node..."
% string
CamlinternalFormatBasics.End_of_format)
"Shutting down the Tezos node..." %
string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Node.shutdown node)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the RPC server..."
% string
CamlinternalFormatBasics.End_of_format)
"Shutting down the RPC server..."
% string))
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteq
(Lwt_list.iter_p
RPC_server.shutdown rpc)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"BYE (" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))
"BYE (%d)" % string)
x)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(Internal_event_unix.close
tt)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
_return retcode))))))))))))))).
Definition process {A : Type}
(sandbox : option (option string)) (verbosity : list A)
(checkpoint : option string) (singleprocess : bool) (args : Node_shared_arg.t)
: variant :=
let verbosity :=
match verbosity with
| [] => None
| cons _ [] => Some Tezos_base__TzPervasives.Internal_event.Info
| _ => Some Tezos_base__TzPervasives.Internal_event.Debug
end in
let run :=
op_gtgteqquestion
(Node_shared_arg.read_and_patch_config_file
(Some
match sandbox with
| Some _ => true
| None => false
end) args)
(fun config =>
op_gtgteqquestion
match sandbox with
| Some _ =>
if equiv_decb (data_dir config) Node_config_file.default_data_dir
then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot use default data directory while in sandbox mode" %
string CamlinternalFormatBasics.End_of_format)
"Cannot use default data directory while in sandbox mode" %
string)
else
return_unit
| None => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match checkpoint with
| None => return_none
| Some s =>
match Block_header.of_b58check s with
| Some b => return_some b
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to parse the provided checkpoint (Base58Check-encoded)."
% string CamlinternalFormatBasics.End_of_format)
"Failed to parse the provided checkpoint (Base58Check-encoded)."
% string)
end
end
(fun checkpoint =>
op_gtgteqquestion
(Lwt_lock_file.is_locked
(Node_data_version.lock_file (data_dir config)))
(fun function_parameter =>
match function_parameter with
| false =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
run verbosity sandbox checkpoint singleprocess config)
(fun function_parameter =>
match function_parameter with
|
Unix_error Unix.EADDRINUSE "bind" % string
"" % string =>
op_gtgteq
(Lwt_list.fold_right_s
(fun addr =>
fun acc =>
op_gtgteq
(Node_config_file.resolve_rpc_listening_addrs
addr)
(fun x =>
Lwt._return (OCaml.Stdlib.app x acc)))
(listen_addrs (rpc config)) [])
(fun addrlist =>
fail
(Tezos_base__TzPervasives.RPC_Port_already_in_use
addrlist))
| exn => Lwt._return (error_exn exn)
end)
| true =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Data directory is locked by another process" %
string CamlinternalFormatBasics.End_of_format)
"Data directory is locked by another process" % string)
end)))) in
match Lwt_main.run run with
| Stdlib.Ok (0 | 2) =>
(* ❌ Variants not supported *)
variant
| Stdlib.Ok _ =>
(* ❌ Variants not supported *)
variant
| Stdlib.Error err =>
(* ❌ Variants not supported *)
variant
end.
Module Term.
Definition verbosity : Cmdliner.Term.t (list bool) :=
let doc :=
"Increase log level. Using $(b,-v) is equivalent to using $(b,TEZOS_LOG='* -> info'), and $(b,-vv) is equivalent to using $(b,TEZOS_LOG='* -> debug')."
% string in
op_and value
(op_and flag_all
(info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
(cons "v" % string []))).
Definition sandbox : Cmdliner.Term.t (option (option string)) :=
let doc :=
"Run the daemon in sandbox mode. P2P to non-localhost addresses are disabled, and constants of the economic protocol can be altered with an optional JSON file. $(b,IMPORTANT): Using sandbox mode affects the node state and subsequent runs of Tezos node must also use sandbox mode. In order to run the node in normal mode afterwards, a full reset must be performed (by removing the node's data directory)."
% string in
op_and value
(op_and (opt (Some (Some None)) (some None (some None string)) None)
(info (Some Node_shared_arg.Manpage.misc_section)
(Some "FILE.json" % string) (Some doc) None
(cons "sandbox" % string []))).
Definition checkpoint : Cmdliner.Term.t (option string) :=
let doc :=
"When asked to take a block hash as a checkpoint, the daemon will only accept the chains that contains that block and those that might reach it."
% string in
op_and value
(op_and (opt None (some None string) None)
(info (Some Node_shared_arg.Manpage.misc_section)
(Some "<level>,<block_hash>" % string) (Some doc) None
(cons "checkpoint" % string []))).
Definition singleprocess : Cmdliner.Term.t bool :=
let doc :=
"When enabled, it deactivates block validation using an external process. Thus, the validation procedure is done in the same process as the node and might not be responding when doing extensive I/Os."
% string in
op_and value
(op_and flag
(info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
(cons "singleprocess" % string []))).
Definition term : Cmdliner.Term.t unit :=
ret
(op_dollar
(op_dollar
(op_dollar (op_dollar (op_dollar (const process) sandbox) verbosity)
checkpoint) singleprocess) Node_shared_arg.Term.args).
End Term.
Module Manpage.
Definition command_description : string :=
"The $(b,run) command is meant to run the Tezos node. Most of its command line arguments corresponds to config file entries, and will have priority over the latter if used."
% string.
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []).
Definition debug : list variant :=
let log_sections :=
String.concat " " % string
(List.rev (Stdlib.op_exclamation Internal_event.Legacy_logging.sections))
in
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []).
Definition examples : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description
(OCaml.Stdlib.app Node_shared_arg.Manpage.args
(OCaml.Stdlib.app debug
(OCaml.Stdlib.app examples Node_shared_arg.Manpage.bugs))).
Definition info : Cmdliner.Term.info :=
Cmdliner.Term.info None (Some man) None None None None
(Some "Run the Tezos node" % string) None "run" % string.
End Manpage.
Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
(Term.term, Manpage.info).
src/bin_node/node_snapshot_command.ml 18 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Node_logging
let ( // ) = Filename.concat
let context_dir data_dir = data_dir // "context"
let store_dir data_dir = data_dir // "store"
(** Main *)
module Term = struct
type subcommand = Export | Import
let dir_cleaner data_dir =
lwt_log_notice "Cleaning directory %s because of failure" data_dir
>>= fun () ->
Lwt_utils_unix.remove_dir @@ store_dir data_dir
>>= fun () -> Lwt_utils_unix.remove_dir @@ context_dir data_dir
let process subcommand args snapshot_file block export_rolling =
let run =
Internal_event_unix.init ()
>>= fun () ->
Node_shared_arg.read_data_dir args
>>=? fun data_dir ->
let genesis = Genesis_chain.genesis in
match subcommand with
| Export ->
Node_data_version.ensure_data_dir data_dir
>>=? fun () ->
let context_root = context_dir data_dir in
let store_root = store_dir data_dir in
Store.init store_root
>>=? fun store ->
Context.init ~readonly:true context_root
>>= fun context_index ->
Snapshots.export
~export_rolling
~context_index
~store
~genesis:genesis.block
snapshot_file
block
>>=? fun () -> Store.close store |> return
| Import ->
Node_data_version.ensure_data_dir ~bare:true data_dir
>>=? fun () ->
Lwt_lock_file.create
~unlink_on_exit:true
(Node_data_version.lock_file data_dir)
>>=? fun () ->
Snapshots.import
~data_dir
~dir_cleaner
~genesis
~patch_context:Patch_context.patch_context
snapshot_file
block
in
match Lwt_main.run run with
| Ok () ->
`Ok ()
| Error err ->
`Error (false, Format.asprintf "%a" pp_print_error err)
let subcommand_arg =
let parser = function
| "export" ->
`Ok Export
| "import" ->
`Ok Import
| s ->
`Error ("invalid argument: " ^ s)
and printer ppf = function
| Export ->
Format.fprintf ppf "export"
| Import ->
Format.fprintf ppf "import"
in
let open Cmdliner.Arg in
let doc =
"Operation to perform. Possible values: $(b,export), $(b,import)."
in
required
& pos 0 (some (parser, printer)) None
& info [] ~docv:"OPERATION" ~doc
let file_arg =
let open Cmdliner.Arg in
required & pos 1 (some string) None & info [] ~docv:"FILE"
let blocks =
let open Cmdliner.Arg in
let doc = "Block hash of the block to export/import." in
value & opt (some string) None & info ~docv:"<block_hash>" ~doc ["block"]
let export_rolling =
let open Cmdliner in
let doc =
"Force export command to dump a minimal snapshot based on the rolling \
mode."
in
Arg.(
value & flag
& info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["rolling"])
let term =
let open Cmdliner.Term in
ret
( const process $ subcommand_arg $ Node_shared_arg.Term.args $ file_arg
$ blocks $ export_rolling )
end
module Manpage = struct
let command_description =
"The $(b,snapshot) command is meant to export and import snapshots files."
let description =
[ `S "DESCRIPTION";
`P (command_description ^ " Several operations are possible: ");
`P
"$(b,export) allows to export a snapshot of the current node state \
into a file.";
`P "$(b,import) allows to import a snapshot from a given file." ]
let options = [`S "OPTIONS"]
let examples =
[ `S "EXAMPLES";
`I
( "$(b,Export a snapshot using the rolling mode)",
"$(mname) snapshot export latest.rolling --rolling" );
`I
( "$(b,Import a snapshot located in file.full)",
"$(mname) snapshot import file.full" ) ]
let man = description @ options @ examples @ Node_shared_arg.Manpage.bugs
let info = Cmdliner.Term.info ~doc:"Manage snapshots" ~man "snapshot"
end
let cmd = (Term.term, Manpage.info)
src/bin_node/node_snapshot_command.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Node_logging.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition context_dir (data_dir : string) : string :=
op_divdiv data_dir "context" % string.
Definition store_dir (data_dir : string) : string :=
op_divdiv data_dir "store" % string.
Module Term.
Inductive subcommand : Type :=
| Export : subcommand
| Import : subcommand.
Definition dir_cleaner (data_dir : string) : Lwt.t unit :=
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cleaning directory " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" because of failure" % string
CamlinternalFormatBasics.End_of_format)))
"Cleaning directory %s because of failure" % string) data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (apply Lwt_utils_unix.remove_dir (store_dir data_dir))
(fun function_parameter =>
let 'tt := function_parameter in
apply Lwt_utils_unix.remove_dir (context_dir data_dir))).
Definition process
(subcommand : subcommand) (args : Node_shared_arg.t)
(snapshot_file : string) (block : option string) (export_rolling : bool)
: variant :=
let run :=
op_gtgteq (Internal_event_unix.init None None tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Node_shared_arg.read_data_dir args)
(fun data_dir =>
let genesis := Genesis_chain.genesis in
match subcommand with
| Export =>
op_gtgteqquestion
(Node_data_version.ensure_data_dir None data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
let context_root := context_dir data_dir in
let store_root := store_dir data_dir in
op_gtgteqquestion (Store.init None None store_root)
(fun store =>
op_gtgteq
(Context.init None None (Some true) context_root)
(fun context_index =>
op_gtgteqquestion
(Snapshots.export (Some export_rolling)
context_index store (block genesis)
snapshot_file block)
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.reverse_apply (Store.close store)
_return))))
| Import =>
op_gtgteqquestion
(Node_data_version.ensure_data_dir (Some true) data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt_lock_file.create None (Some true)
(Node_data_version.lock_file data_dir))
(fun function_parameter =>
let 'tt := function_parameter in
Snapshots.import data_dir dir_cleaner
Patch_context.patch_context genesis snapshot_file
block))
end)) in
match Lwt_main.run run with
| Stdlib.Ok tt =>
(* ❌ Variants not supported *)
variant
| Stdlib.Error err =>
(* ❌ Variants not supported *)
variant
end.
Definition subcommand_arg : Cmdliner.Term.t subcommand :=
let parser (function_parameter : string) : variant :=
match function_parameter with
| "export" % string =>
(* ❌ Variants not supported *)
variant
| "import" % string =>
(* ❌ Variants not supported *)
variant
| s =>
(* ❌ Variants not supported *)
variant
end
with printer
(ppf : Stdlib.Format.formatter) (function_parameter : subcommand)
: unit :=
match function_parameter with
| Export =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "export" % string
CamlinternalFormatBasics.End_of_format) "export" % string)
| Import =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "import" % string
CamlinternalFormatBasics.End_of_format) "import" % string)
end in
let doc :=
"Operation to perform. Possible values: $(b,export), $(b,import)." %
string in
op_and required
(op_and (pos None 0 (some None (parser, printer)) None)
(info None (Some "OPERATION" % string) (Some doc) None [])).
Definition file_arg : Cmdliner.Term.t string :=
op_and required
(op_and (pos None 1 (some None string) None)
(info None (Some "FILE" % string) None None [])).
Definition blocks : Cmdliner.Term.t (option string) :=
let doc := "Block hash of the block to export/import." % string in
op_and value
(op_and (opt None (some None string) None)
(info None (Some "<block_hash>" % string) (Some doc) None
(cons "block" % string []))).
Definition export_rolling : Cmdliner.Term.t bool :=
let doc :=
"Force export command to dump a minimal snapshot based on the rolling mode."
% string in
op_and value
(op_and flag
(info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
(cons "rolling" % string []))).
Definition term : Cmdliner.Term.t unit :=
ret
(op_dollar
(op_dollar
(op_dollar
(op_dollar (op_dollar (const process) subcommand_arg)
Node_shared_arg.Term.args) file_arg) blocks) export_rolling).
End Term.
Module Manpage.
Definition command_description : string :=
"The $(b,snapshot) command is meant to export and import snapshots files." %
string.
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []))).
Definition options : list variant :=
cons
(* ❌ Variants not supported *)
variant [].
Definition examples : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description
(OCaml.Stdlib.app options
(OCaml.Stdlib.app examples Node_shared_arg.Manpage.bugs)).
Definition info : Cmdliner.Term.info :=
Cmdliner.Term.info None (Some man) None None None None
(Some "Manage snapshots" % string) None "snapshot" % string.
End Manpage.
Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
(Term.term, Manpage.info).
src/bin_node/patch_context.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Genesis_chain
let patch_context key_json ctxt =
( match key_json with
| None ->
Lwt.return ctxt
| Some (key, json) ->
Tezos_storage.Context.set
ctxt
[key]
(Data_encoding.Binary.to_bytes_exn Data_encoding.json json) )
>>= fun ctxt ->
(* TODO: this code seems to be shared with validator.ml, function run:
can we share it? *)
match Registered_protocol.get genesis.protocol with
| None ->
assert false (* FIXME error *)
| Some proto -> (
let module Proto = (val proto) in
let ctxt = Shell_context.wrap_disk_context ctxt in
Proto.init
ctxt
{
level = 0l;
proto_level = 0;
predecessor = genesis.block;
timestamp = genesis.time;
validation_passes = 0;
operations_hash = Operation_list_list_hash.empty;
fitness = [];
context = Context_hash.zero;
}
>>= function
| Error _ ->
assert false (* FIXME error *)
| Ok {context; _} ->
let context = Shell_context.unwrap_disk_context context in
Lwt.return context )
src/bin_node/patch_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Genesis_chain.
Definition patch_context
(key_json : option (string * Tezos_base__TzPervasives.Data_encoding.json))
(ctxt : Tezos_storage.Context.context) : Lwt.t Tezos_storage.Context.t :=
op_gtgteq
match key_json with
| None => Lwt._return ctxt
| Some (key, json) =>
Tezos_storage.Context.set ctxt (cons key [])
(Data_encoding.Binary.to_bytes_exn Data_encoding.json json)
end
(fun ctxt =>
match Registered_protocol.get (protocol genesis) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some proto =>
let Proto := projT2 proto in
let ctxt := Shell_context.wrap_disk_context ctxt in
op_gtgteq
(Proto.(Tezos_protocol_updater__Registered_protocol.T.init) ctxt
{|
level :=
(* ❌ Constant of type int32 is converted to int *)
0; proto_level := 0; predecessor := block genesis;
timestamp := time genesis; validation_passes := 0;
operations_hash := Operation_list_list_hash.empty; fitness := [];
context := Context_hash.zero |})
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok {| context := context |} =>
let context := Shell_context.unwrap_disk_context context in
Lwt._return context
end)
end).
src/bin_sandbox/command_accusations.ml 419 errors
open Flextesa
open Internal_pervasives
open Console
let default_attempts = 35
let little_mesh_with_bakers ?base_port ?generate_kiln_config state ~protocol
~starting_level ~node_exec ~client_exec ~bakers () =
Helpers.clear_root state
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[af "Ready to start"; af "Root path deleted."]
>>= fun () ->
let block_interval = 1 in
let (protocol, baker_list) =
let d = protocol in
let open Tezos_protocol in
let bakers = List.take d.bootstrap_accounts bakers in
( {
d with
time_between_blocks = [block_interval; 0];
bootstrap_accounts =
List.map d.bootstrap_accounts ~f:(fun (n, v) ->
if List.exists bakers ~f:(fun baker -> n = fst baker) then (n, v)
else (n, 1_000L));
},
bakers )
in
let net_size = 3 in
let topology = Test_scenario.Topology.(mesh "Simple" net_size) in
let all_nodes =
Test_scenario.Topology.build ~protocol ~exec:node_exec topology ?base_port
in
Helpers.dump_connections state all_nodes
>>= fun () ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes:all_nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]) ;
Test_scenario.Network.(start_up state ~client_exec (make all_nodes))
>>= fun () ->
let baker nth_node =
let nth_baker = nth_node mod List.length baker_list in
let key_name = sprintf "b%d" nth_baker in
let node = List.nth_exn all_nodes nth_node in
let client = Tezos_client.of_node node ~exec:client_exec in
let baker_account = List.nth_exn baker_list nth_baker in
let bak =
Tezos_client.Keyed.make
client
~key_name
~secret_key:(Tezos_protocol.Account.private_key (fst baker_account))
in
Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak)
in
baker 0
>>= fun (client_0, baker_0) ->
baker 1
>>= fun (client_1, baker_1) ->
baker 2
>>= fun (client_2, baker_2) ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
arbitrary_commands_for_each_and_all_clients
state
~clients:[client_0; client_1; client_2]) ;
Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config ->
Tezos_client.rpc
state
~client:client_0
`Get
~path:"/chains/main/chain_id"
>>= fun chain_id_json ->
let network_id =
match chain_id_json with `String s -> s | _ -> assert false
in
Kiln.Configuration_directory.generate
state
kiln_config
~peers:
(List.map all_nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port))
~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol)
~nodes:
(List.map all_nodes ~f:(fun {Tezos_node.rpc_port; _} ->
sprintf "http://localhost:%d" rpc_port))
~bakers:
(List.map
protocol.Tezos_protocol.bootstrap_accounts
~f:(fun (account, _) ->
Tezos_protocol.Account.(name account, pubkey_hash account)))
~network_string:network_id
~node_exec
~client_exec
>>= fun () ->
return EF.(wf "Kiln was configured at `%s`" kiln_config.path))
>>= fun _ ->
let bake msg baker = Tezos_client.Keyed.bake state baker msg in
List.fold
(List.init (starting_level - 1) ~f:(fun n -> n))
~init:(return ()) (* We are already at level 1, we bake 7 times: *)
~f:(fun pm n ->
pm
>>= fun () ->
bake
(sprintf "first bakes: [%d/%d]" (n + 1) (starting_level - 1))
baker_0)
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to starting_level)
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.
[ af "Clients ready";
af "Node 0 baked %d times." (starting_level - 1);
af "All nodes should be at level %d." starting_level ]
>>= fun () ->
return (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2)
let wait_for_operation_in_mempools state ~nodes:all_nodes ~kind ~client_exec
how =
let (init, combine) =
match how with `At_least_one -> (false, ( || )) | `All -> (true, ( && ))
in
Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ ->
List.fold ~init:(return init) all_nodes ~f:(fun prev_m node ->
prev_m
>>= fun prev ->
let client = Tezos_client.of_node node ~exec:client_exec in
Tezos_client.mempool_has_operation state ~client ~kind
>>= fun client_result -> return (combine client_result prev))
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf "Waiting for %S to show up in the mempool" kind)))
let simple_double_baking ~starting_level ?generate_kiln_config ~state ~protocol
~base_port node_exec client_exec () =
little_mesh_with_bakers
~bakers:1
~protocol
state
~node_exec
~client_exec
()
~base_port
~starting_level
?generate_kiln_config
>>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) ->
let kill_nth nth = List.nth_exn all_nodes nth |> Helpers.kill_node state in
let restart_nth nth =
List.nth_exn all_nodes nth |> Helpers.restart_node ~client_exec state
in
let number_of_lonely_bakes = 1 in
kill_nth 1
>>= fun () ->
kill_nth 2
>>= fun () ->
Loop.n_times (number_of_lonely_bakes - 1) (fun _ ->
Tezos_client.Keyed.bake state baker_0 "Bake-on-0")
>>= fun () ->
(* Bake one block less and inject an operation to generate a different
block's hash *)
Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
>>= fun () ->
Tezos_client.Keyed.bake state baker_0 "Bake-on-0"
>>= fun () ->
Tezos_client.get_block_header state ~client:client_0 `Head
>>= fun baking_0_header ->
(* This baking will have better fitness so other nodes will have to fetch it. *)
Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
>>= fun () ->
System.sleep 1.
>>= fun () ->
kill_nth 0
>>= fun () ->
restart_nth 1
>>= fun () ->
restart_nth 2
>>= fun () ->
Loop.n_times number_of_lonely_bakes (fun _ ->
Tezos_client.Keyed.bake state baker_1 "Bake-on-1")
>>= fun () ->
Tezos_client.get_block_header state ~client:client_1 `Head
>>= fun baking_1_header ->
restart_nth 0
>>= fun () ->
Tezos_client.Keyed.bake state baker_0 "Bake-on-0"
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`At_least (starting_level + number_of_lonely_bakes + 1))
>>= fun () ->
Tezos_client.rpc
state
~client:client_1
`Get
~path:"/chains/main/blocks/head/hash"
>>= fun head_hash_json ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to forge";
ef_json "Baking 0" baking_0_header;
ef_json "Baking 1" baking_1_header;
ef_json "Head hash" head_hash_json ]
>>= fun () ->
Tezos_client.Keyed.forge_and_inject
state
baker_1
~json:
(let clean header =
let open Jqo in
remove_field header ~name:"hash"
|> remove_field ~name:"chain_id"
|> remove_field ~name:"protocol"
in
`O
[ ("branch", head_hash_json);
( "contents",
`A
[ `O
[ ("kind", `String "double_baking_evidence");
("bh1", clean baking_0_header);
("bh2", clean baking_1_header) ] ] ) ])
>>= fun result ->
Interactive_test.Pauser.generic
state
EF.
[ af "Waiting for accuser to notice double baking";
ef_json "Result of injection" result;
af
"All nodes reaching level %d"
(starting_level + number_of_lonely_bakes + 1) ]
>>= fun () ->
wait_for_operation_in_mempools
state
~nodes:all_nodes
~kind:"double_baking_evidence"
~client_exec
`All
>>= fun () ->
Tezos_client.Keyed.bake
state
baker_2
(sprintf "all at lvl %d" (starting_level + number_of_lonely_bakes + 1))
>>= fun () ->
let last_level = starting_level + number_of_lonely_bakes + 2 in
Interactive_test.Pauser.generic
state
EF.[af "Just baked what's the level? Vs %d" last_level]
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to last_level)
>>= fun () ->
Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
Tezos_client.block_has_operation
state
~client:client_2
~level:last_level
~kind:"double_baking_evidence"
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf
"Waiting for accusation to show up in block %d"
last_level)))
>>= fun () -> say state EF.(af "Test done.")
let find_endorsement_in_mempool state ~client =
Helpers.wait_for state ~attempts:4 ~seconds:2. (fun _ ->
Tezos_client.find_applied_in_mempool state ~client ~f:(fun o ->
Jqo.field o ~k:"contents"
|> Jqo.list_exists ~f:(fun op ->
(* Dbg.e EF.(ef_json "op" op) ; *)
Jqo.field op ~k:"kind" = `String "endorsement"))
>>= function
| None ->
return (`Not_done (sprintf "No endorsement so far"))
| Some e ->
return (`Done e))
let simple_double_endorsement ~starting_level ?generate_kiln_config ~state
~protocol ~base_port node_exec client_exec () =
little_mesh_with_bakers
~bakers:2
~protocol
state
~node_exec
~client_exec
()
~starting_level
~base_port
?generate_kiln_config
>>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) ->
(* 2 bakers â baker_0 and baker_2 are for the same key on â nodes *)
assert (
Tezos_client.Keyed.(
baker_0.key_name = baker_2.key_name
&& baker_0.secret_key = baker_2.secret_key) ) ;
let node_0 = List.nth_exn all_nodes 0 in
let node_1 = List.nth_exn all_nodes 1 in
let node_2 = List.nth_exn all_nodes 2 in
let baker_1_n0 =
let open Tezos_client.Keyed in
let {key_name; secret_key; _} = baker_1 in
make client_0 ~key_name ~secret_key
in
Tezos_client.Keyed.initialize state baker_1_n0
>>= fun _ ->
Helpers.kill_node state node_1
>>= fun () ->
Helpers.kill_node state node_2
>>= fun () ->
(* Inject an operation to generate a different block's hash *)
Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
>>= fun () ->
Tezos_client.Keyed.bake state baker_0 "baker-0 baking with node 0"
>>= fun () ->
Tezos_client.Keyed.endorse state baker_0 "baker-0 endorsing with node 0"
>>= fun () ->
find_endorsement_in_mempool state ~client:client_0
>>= fun endorsement_0 ->
Tezos_client.Keyed.endorse state baker_1_n0 "baker-1 endorsing with node 0"
>>= fun () ->
Helpers.kill_node state node_0
>>= fun () ->
Helpers.restart_node state node_2 ~client_exec
>>= fun () ->
Tezos_client.Keyed.bake state baker_2 "baker-0 baking with node 2"
>>= fun () ->
Tezos_client.Keyed.endorse state baker_2 "baker-0 endorsing with node 2"
>>= fun () ->
find_endorsement_in_mempool state ~client:client_2
>>= fun endorsement_1 ->
say
state
EF.(
list
[ ef_json "Endorsement 0:" endorsement_0;
ef_json "Endorsement 1:" endorsement_1 ])
>>= fun () ->
Helpers.restart_node state node_1 ~client_exec
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
[node_1; node_2]
(`Equal_to (starting_level + 1))
>>= fun () ->
Helpers.restart_node state node_0 ~client_exec
>>= fun () ->
(* TODO: understand why this kick in the butt is necessary for node
2 (seems like the node was not getting to level starting+2 without
this). *)
Helpers.kill_node state node_2
>>= fun () ->
Helpers.restart_node state node_2 ~client_exec
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to (starting_level + 1))
>>= fun () ->
Tezos_client.rpc
state
~client:client_1
`Get
~path:"/chains/main/blocks/head/hash"
>>= fun head_hash_json ->
let double_endorsement =
let transform_endorsement endorsement =
let branch = Jqo.field ~k:"branch" endorsement in
let signature = Jqo.field ~k:"signature" endorsement in
let contents =
match Jqo.field ~k:"contents" endorsement with
| `A [one] ->
one
| _ ->
assert false
in
`O
[("branch", branch); ("operations", contents); ("signature", signature)]
in
let inlined_endorsement_1 = transform_endorsement endorsement_0 in
let inlined_endorsement_2 = transform_endorsement endorsement_1 in
`O
[ ("branch", head_hash_json);
( "contents",
`A
[ `O
[ ("kind", `String "double_endorsement_evidence");
("op1", inlined_endorsement_1);
("op2", inlined_endorsement_2) ] ] ) ]
in
Interactive_test.Pauser.generic
state
EF.[ef_json "About to forge" double_endorsement]
>>= fun () ->
Tezos_client.Keyed.forge_and_inject state baker_1 ~json:double_endorsement
>>= fun result ->
Interactive_test.Pauser.generic
state
EF.[ef_json "Result of injection" result]
>>= fun () ->
wait_for_operation_in_mempools
state
~nodes:[node_1]
~kind:"double_endorsement_evidence"
~client_exec
`All
>>= fun () ->
let last_level = starting_level + 2 in
Tezos_client.Keyed.bake state baker_1 (sprintf "level %d" last_level)
>>= fun () ->
Tezos_client.Keyed.endorse
state
baker_1
(sprintf "endorse level %d" last_level)
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to last_level)
>>= fun () ->
Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
(* We check that client-2 sees the evidence from baker-1 *)
Tezos_client.block_has_operation
state
~client:client_2
~level:last_level
~kind:"double_endorsement_evidence"
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf
"Waiting for accusation to show up in block %d"
last_level)))
>>= fun () -> say state EF.(af "Test done.")
let with_accusers ~state ~protocol ~base_port node_exec accuser_exec
client_exec () =
Helpers.clear_root state
>>= fun () ->
let block_interval = 2 in
let (protocol, baker_0_account) =
let d = protocol in
let open Tezos_protocol in
let baker = List.hd_exn d.bootstrap_accounts in
( {
d with
time_between_blocks = [block_interval; block_interval * 2];
bootstrap_accounts =
List.map d.bootstrap_accounts ~f:(fun (n, v) ->
if n = fst baker then (n, v) else (n, 1_000L));
},
baker )
in
let topology =
Test_scenario.Topology.(
net_in_the_middle "AT-" (mesh "Mid" 3) (mesh "Main" 4) (mesh "Acc" 4))
in
let (mesh_nodes, intermediary_nodes, accuser_nodes) =
Test_scenario.Topology.build ~protocol ~exec:node_exec topology ~base_port
in
let all_nodes = mesh_nodes @ intermediary_nodes @ accuser_nodes in
Helpers.dump_connections state all_nodes
>>= fun () ->
Test_scenario.Network.(start_up state ~client_exec (make all_nodes))
>>= fun () ->
let start_accuser nod =
let client = Tezos_client.of_node nod ~exec:client_exec in
let acc = Tezos_daemon.accuser_of_node ~exec:accuser_exec ~client nod in
Running_processes.start state (Tezos_daemon.process acc ~state)
>>= fun _ -> return ()
in
List_sequential.iter accuser_nodes ~f:start_accuser
>>= fun () ->
let key_name = "b0" in
let baker nth =
let node = List.nth_exn all_nodes nth in
let client = Tezos_client.of_node node ~exec:client_exec in
let bak =
Tezos_client.Keyed.make
client
~key_name
~secret_key:(Tezos_protocol.Account.private_key (fst baker_0_account))
in
Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak)
in
baker 0
>>= fun (client_0, baker_0) ->
baker 1
>>= fun (client_1, baker_1) ->
baker 2
>>= fun (client_2, baker_2) ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes:all_nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
@ arbitrary_commands_for_each_and_all_clients
state
~clients:[client_0; client_1; client_2]) ;
let pause ?force msgs = Interactive_test.Pauser.generic state ?force msgs in
let starting_level = 10 in
List.fold
(List.init (starting_level - 1) ~f:(fun n -> n))
~init:(return ()) (* We are already at level 1, we bake 7 times: *)
~f:(fun pm n ->
pm
>>= fun () ->
Tezos_client.Keyed.bake
state
baker_0
(sprintf "first bakes: [%d/%d]" (n + 1) (starting_level - 1)))
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to starting_level)
>>= fun () ->
pause
EF.
[ af "Two clients ready";
af "Node 0 baked %d times." (starting_level - 1);
af "All nodes should be at level %d." starting_level ]
>>= fun () ->
let transfer _msg client =
let dest =
List.random_element_exn protocol.Tezos_protocol.bootstrap_accounts
|> fst |> Tezos_protocol.Account.pubkey_hash
in
Tezos_client.successful_client_cmd
state
~client
[ "--wait";
"none";
"transfer";
"1";
"from";
key_name;
"to";
dest;
"--fee";
"0.05" ]
>>= fun res ->
say
state
EF.(
desc
(af "Successful transfer (%s):" client.Tezos_client.id)
(ocaml_string_list res#out))
in
List_sequential.iter intermediary_nodes ~f:(fun x ->
Helpers.kill_node state x)
>>= fun () ->
let kill_all_but nodes iths =
List_sequential.iteri nodes ~f:(fun ith n ->
if List.mem iths ith ~equal:Int.equal then return ()
else Helpers.kill_node state n)
in
let kill_nth_node nodes nth =
Helpers.kill_node
state
(Option.value_exn ~message:"kill_nth_node" (List.nth nodes nth))
in
let restart_nth_node nodes nth =
Helpers.restart_node
state
~client_exec
(Option.value_exn ~message:"restart_nth_node" (List.nth nodes nth))
in
let get_block_header ~client block =
let path =
sprintf
"/chains/main/blocks/%s/header"
(match block with `Head -> "head" | `Level i -> Int.to_string i)
in
Tezos_client.rpc state ~client `Get ~path
in
kill_all_but mesh_nodes [0]
>>= fun () ->
let number_of_lonely_bakes = 1 in
pause EF.[af "Node 0 is the only one alive"]
>>= fun () ->
transfer "node0 only alive" client_0
>>= fun () ->
Loop.n_times number_of_lonely_bakes (fun n ->
Tezos_client.Keyed.bake state baker_0 (sprintf "n0 only alive: %d" n))
>>= fun () ->
get_block_header ~client:client_0 `Head
>>= fun _baking_0_header ->
Tezos_client.Keyed.endorse state baker_0 "self-endorsing"
>>= fun () ->
Tezos_client.Keyed.bake state baker_0 "baking self-endorsement"
>>= fun () ->
kill_nth_node mesh_nodes 0
>>= fun () ->
restart_nth_node mesh_nodes 1
>>= fun () ->
transfer "node1 only one alive" client_1
>>= fun () ->
Loop.n_times number_of_lonely_bakes (fun _ ->
Tezos_client.Keyed.bake state baker_1 "after transfer")
>>= fun () ->
get_block_header ~client:client_1 `Head
>>= fun _baking_1_header ->
kill_nth_node mesh_nodes 1
>>= fun () ->
pause
EF.
[ af "Node 0 was killed";
af "Node 1 was restarted";
af "Node 1 transfered";
af "Node 1 baked";
af "Node 1 was killed" ]
>>= fun () ->
List.fold ~init:(return ()) intermediary_nodes ~f:(fun prev x ->
prev >>= fun () -> Helpers.restart_node state ~client_exec x)
>>= fun () ->
let node_0 = List.nth_exn mesh_nodes 0 in
let except_0 l = List.filter l ~f:Tezos_node.(fun n -> n.id <> node_0.id) in
List_sequential.iter
(except_0 mesh_nodes)
~f:(Helpers.restart_node state ~client_exec)
>>= fun () ->
pause EF.[af "All nodes restarted Except 0"]
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
(except_0 all_nodes)
(`At_least (starting_level + number_of_lonely_bakes))
>>= fun () ->
Helpers.restart_node state ~client_exec node_0
>>= fun () ->
pause EF.[af "Restarted 0"]
>>= fun () ->
Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ ->
List.fold ~init:(return false) accuser_nodes ~f:(fun prev_m node ->
prev_m
>>= fun prev ->
let client = Tezos_client.of_node node ~exec:client_exec in
Tezos_client.mempool_has_operation
state
~client
~kind:"double_baking_evidence"
>>= fun client_result -> return (client_result || prev))
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf "Waiting for accusation to show up in the mempool")))
>>= fun () ->
Tezos_client.Keyed.bake
state
baker_2
(sprintf "all at lvl %d" (starting_level + number_of_lonely_bakes + 1))
>>= fun () ->
Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
let level = starting_level + number_of_lonely_bakes + 2 in
Tezos_client.block_has_operation
state
~client:client_2
~level
~kind:"double_baking_evidence"
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf "Waiting for accusation to show up in block %d" level)))
>>= fun () ->
pause
EF.
[ af "One more baking (level should include accusation)";
af
"All nodes reaching level %d"
(starting_level + number_of_lonely_bakes + 2) ]
>>= fun () ->
Tezos_client.Keyed.bake state baker_1 "a couple more"
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`At_least (starting_level + number_of_lonely_bakes + 1))
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
let pf fmt = ksprintf (fun s -> `P s) fmt in
let tests =
let test variant name title man = (variant, name, title, man) in
[ test
`With_accusers
"with-accusers"
"Network With Accusers"
(pf
"This test builds a network with 3 interconnected meshes: Main, \
Intermediate, and Accuser.");
test
`Simple_double_baking
"simple-double-baking"
"Simple Network With Manual Double Baking Accusation"
(pf
"This test builds a very simple 3-piece network, makes a baker \
double bake and $(i,manually) inserts a double-baking accusation.");
test
`Simple_double_endorsing
"simple-double-endorsing"
"Simple Network With Manual Double Endorsing Accusation"
(pf
"This test builds a very simple 3-piece network, makes a baker \
double endorse and $(i,manually) inserts a double-baking \
accusation.") ]
in
Test_command_line.Run_command.make
~pp_error
( pure
(fun test
base_port
(`Starting_level starting_level)
bnod
bcli
accex
generate_kiln_config
protocol
state
->
let checks () =
let acc = if test = `With_accusers then [accex] else [] in
Helpers.System_dependencies.precheck
state
`Or_fail
~executables:(acc @ [bnod; bcli])
in
let actual_test () =
match test with
| `With_accusers ->
checks ()
>>= fun () ->
with_accusers ~state bnod accex bcli ~base_port () ~protocol
| `Simple_double_baking ->
checks ()
>>= fun () ->
simple_double_baking
~state
bnod
bcli
~base_port
?generate_kiln_config
~starting_level
~protocol
()
| `Simple_double_endorsing ->
checks ()
>>= fun () ->
simple_double_endorsement
~state
bnod
bcli
~base_port
?generate_kiln_config
~starting_level
~protocol
()
in
(state, Interactive_test.Pauser.run_test ~pp_error state actual_test))
$ Arg.(
required
(pos
0
(some (enum (List.map tests ~f:(fun (v, n, _, _) -> (n, v)))))
None
(info [] ~docv:"TEST-NAME" ~doc:"Choose which test to run.")))
$ Arg.(
value & opt int 30_000
& info ["base-port"] ~doc:"Base port number to build upon.")
$ Arg.(
pure (fun l -> `Starting_level l)
$ value
(opt
int
5
(info
["starting-level"]
~doc:
"Initial block-level to reach before actually starting \
the test.")))
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Tezos_executable.cli_term `Accuser "tezos"
$ Kiln.Configuration_directory.cli_term ()
$ Tezos_protocol.cli_term ()
$ Test_command_line.cli_state ~name:"accusing" () )
(let doc = "Sandbox networks which record double-bakings." in
let man : Manpage.block list =
[ `S "ACCUSATION TESTS";
pf
"This command provides %d tests which use network sandboxes to \
make double-bakings and double-endorsements happen."
(List.length tests);
`Blocks
(List.map tests ~f:(fun (_, n, tit, m) ->
`Blocks [pf "* $(b,`%s`): $(i,%s)." n tit; `Noblank; m])) ]
in
info ~man ~doc "accusations")
src/bin_sandbox/command_accusations.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition default_attempts : Z := 35.
Definition little_mesh_with_bakers {A B C D E F G H : Type}
(base_port : option A) (generate_kiln_config : option B) (state : C)
(protocol : D) (starting_level : Z) (node_exec : E) (client_exec : F)
(bakers : G) (function_parameter : unit) : H :=
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let block_interval := 1 in
let '(protocol, baker_list) :=
let d := protocol in
op_startypeminuserrorstar in
let net_size := 3 in
let topology := op_startypeminuserrorstar in
let all_nodes :=
op_startypeminuserrorstar protocol node_exec topology base_port in
op_startypeminuserrorstar (op_startypeminuserrorstar state all_nodes)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar state op_startypeminuserrorstar
in
op_startypeminuserrorstar op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let baker {I : Type} (nth_node : Z) : I :=
let nth_baker :=
Z.modulo nth_node (OCaml.List.length baker_list) in
let key_name :=
op_startypeminuserrorstar "b%d" % string nth_baker in
let node := op_startypeminuserrorstar all_nodes nth_node in
let client := op_startypeminuserrorstar node client_exec in
let baker_account :=
op_startypeminuserrorstar baker_list nth_baker in
let bak :=
op_startypeminuserrorstar client key_name
(op_startypeminuserrorstar (fst baker_account)) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state bak)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar (client, bak)) in
op_startypeminuserrorstar (baker 0)
(fun function_parameter =>
let '(client_0, baker_0) := function_parameter in
op_startypeminuserrorstar (baker 1)
(fun function_parameter =>
let '(client_1, baker_1) := function_parameter in
op_startypeminuserrorstar (baker 2)
(fun function_parameter =>
let '(client_2, baker_2) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar generate_kiln_config
(fun kiln_config =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client_0
(* ❌ Variants not supported *)
variant "/chains/main/chain_id" % string)
(fun chain_id_json =>
let network_id :=
match chain_id_json with
| String s => s
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
kiln_config
(List.map all_nodes
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar))
(op_startypeminuserrorstar state
protocol)
(List.map all_nodes
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
"http://localhost:%d" % string
op_startypeminuserrorstar))
(List.map
(Tezos_protocol.bootstrap_accounts
protocol)
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '(account, _) :=
function_parameter in
op_startypeminuserrorstar))
network_id node_exec client_exec)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
op_startypeminuserrorstar))))
(fun function_parameter =>
let '_ := function_parameter in
let bake {I J K : Type} (msg : I) (baker : J)
: K :=
op_startypeminuserrorstar state baker msg in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(Stdlib.List.init (Z.sub starting_level 1)
(* ❌ expected an argument *)
expected_argument (fun n => n))
(op_startypeminuserrorstar tt)
(fun pm =>
fun n =>
op_startypeminuserrorstar pm
(fun function_parameter =>
let 'tt := function_parameter in
bake
(op_startypeminuserrorstar
"first bakes: [%d/%d]" %
string (Z.add n 1)
(Z.sub starting_level 1))
baker_0)))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8 all_nodes
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(all_nodes, client_0, baker_0,
client_1, baker_1, client_2,
baker_2)))))))))))).
Definition wait_for_operation_in_mempools {A B C D E : Type}
(state : A) (all_nodes : B) (kind : C) (client_exec : D) (how : variant)
: E :=
let '(init, combine) :=
match how with
| At_least_one => (false, orb)
| All => (true, andb)
end in
op_startypeminuserrorstar state default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar (op_startypeminuserrorstar init) all_nodes
(fun prev_m =>
fun node =>
op_startypeminuserrorstar prev_m
(fun prev =>
let client := op_startypeminuserrorstar node client_exec in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client kind)
(fun client_result =>
op_startypeminuserrorstar (combine client_result prev)))))
(fun function_parameter =>
match function_parameter with
| true =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| false =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)).
Definition simple_double_baking {A B C D E F G : Type}
(starting_level : Z) (generate_kiln_config : option A) (state : B)
(protocol : C) (base_port : D) (node_exec : E) (client_exec : F)
(function_parameter : unit) : G :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(little_mesh_with_bakers (Some base_port) generate_kiln_config state
protocol starting_level node_exec client_exec 1 tt)
(fun function_parameter =>
let
'(all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) :=
function_parameter in
let kill_nth {H I : Type} (nth : H) : I :=
OCaml.Stdlib.reverse_apply (op_startypeminuserrorstar all_nodes nth)
(op_startypeminuserrorstar state) in
let restart_nth {H I : Type} (nth : H) : I :=
OCaml.Stdlib.reverse_apply (op_startypeminuserrorstar all_nodes nth)
(op_startypeminuserrorstar client_exec state) in
let number_of_lonely_bakes := 1 in
op_startypeminuserrorstar (kill_nth 1)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (kill_nth 2)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar (Z.sub number_of_lonely_bakes 1)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar state baker_0 "Bake-on-0" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"endorsing lonely bake-on-0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"Bake-on-0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client_0
(* ❌ Variants not supported *)
variant)
(fun baking_0_header =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"endorsing lonely bake-on-0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(* ❌ Float constant 1. is approximated by the integer 1 *)
1)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (kill_nth 0)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(restart_nth 1)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(restart_nth 2)
(fun function_parameter =>
let 'tt := function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
number_of_lonely_bakes
(fun function_parameter =>
let '_ :=
function_parameter in
op_startypeminuserrorstar
state baker_1
"Bake-on-1" % string))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state client_1
(* ❌ Variants not supported *)
variant)
(fun baking_1_header =>
op_startypeminuserrorstar
(restart_nth 0)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker_0
"Bake-on-0" %
string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_1
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/hash"
%
string)
(fun
head_hash_json
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
(let
clean
{H
I
:
Type}
(header
:
H)
: I :=
op_startypeminuserrorstar
in
(* ❌ Variants not supported *)
variant))
(fun
result
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_operation_in_mempools
state
all_nodes
"double_baking_evidence"
%
string
client_exec
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_2
(op_startypeminuserrorstar
"all at lvl %d"
%
string
(Z.add
(Z.add
starting_level
number_of_lonely_bakes)
1)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
last_level :=
Z.add
(Z.add
starting_level
number_of_lonely_bakes)
2
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
10
(* ❌ Float constant 4. is approximated by the integer 4 *)
4
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_2
last_level
"double_baking_evidence"
%
string)
(fun
function_parameter
=>
match
function_parameter
with
|
true
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
false
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)))))))))))))))))))))))))).
Definition find_endorsement_in_mempool {A B C : Type} (state : A) (client : B)
: C :=
op_startypeminuserrorstar state 4
(* ❌ Float constant 2. is approximated by the integer 2 *)
2
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(fun o =>
OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar o "contents" % string)
(op_startypeminuserrorstar
(fun op =>
equiv_decb (op_startypeminuserrorstar op "kind" % string)
(* ❌ Variants not supported *)
variant))))
(fun function_parameter =>
match function_parameter with
| None =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| Some e =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)).
Definition simple_double_endorsement {A B C D E F G : Type}
(starting_level : Z) (generate_kiln_config : option A) (state : B)
(protocol : C) (base_port : D) (node_exec : E) (client_exec : F)
(function_parameter : unit) : G :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(little_mesh_with_bakers (Some base_port) generate_kiln_config state
protocol starting_level node_exec client_exec 2 tt)
(fun function_parameter =>
let
'(all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) :=
function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert op_startypeminuserrorstar in
let node_0 := op_startypeminuserrorstar all_nodes 0 in
let node_1 := op_startypeminuserrorstar all_nodes 1 in
let node_2 := op_startypeminuserrorstar all_nodes 2 in
let baker_1_n0 := op_startypeminuserrorstar in
op_startypeminuserrorstar (op_startypeminuserrorstar state baker_1_n0)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state node_1)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state node_2)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"endorsing lonely bake-on-0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"baker-0 baking with node 0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"baker-0 endorsing with node 0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(find_endorsement_in_mempool state client_0)
(fun endorsement_0 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_1_n0
"baker-1 endorsing with node 0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state node_0)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
node_2 client_exec)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
baker_2
"baker-0 baking with node 2" %
string)
(fun function_parameter =>
let 'tt := function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker_2
"baker-0 endorsing with node 2"
% string)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(find_endorsement_in_mempool
state client_2)
(fun endorsement_1 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state node_1
client_exec)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
(cons
node_1
(cons
node_2
[]))
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
node_0
client_exec)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
node_2)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
node_2
client_exec)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_1
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/hash"
%
string)
(fun
head_hash_json
=>
let
double_endorsement :=
let
transform_endorsement
{H
:
Type}
(endorsement
:
H)
: variant :=
let
branch :=
op_startypeminuserrorstar
"branch"
%
string
endorsement
in
let
signature :=
op_startypeminuserrorstar
"signature"
%
string
endorsement
in
let
contents :=
match
op_startypeminuserrorstar
"contents"
%
string
endorsement
with
|
A
(cons
one
[])
=>
one
|
_
=>
(* ❌ Assert instruction is not handled. *)
assert
false
end
in
(* ❌ Variants not supported *)
variant
in
let
inlined_endorsement_1 :=
transform_endorsement
endorsement_0
in
let
inlined_endorsement_2 :=
transform_endorsement
endorsement_1
in
(* ❌ Variants not supported *)
variant
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
double_endorsement)
(fun
result
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_operation_in_mempools
state
(cons
node_1
[])
"double_endorsement_evidence"
%
string
client_exec
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
last_level :=
Z.add
starting_level
2
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
(op_startypeminuserrorstar
"level %d"
%
string
last_level))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
(op_startypeminuserrorstar
"endorse level %d"
%
string
last_level))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
10
(* ❌ Float constant 4. is approximated by the integer 4 *)
4
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_2
last_level
"double_endorsement_evidence"
%
string)
(fun
function_parameter
=>
match
function_parameter
with
|
true
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
false
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)))))))))))))))))))))))))))))).
Definition with_accusers {A B C D E F G : Type}
(state : A) (protocol : B) (base_port : C) (node_exec : D) (accuser_exec : E)
(client_exec : F) (function_parameter : unit) : G :=
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
let block_interval := 2 in
let '(protocol, baker_0_account) :=
let d := protocol in
op_startypeminuserrorstar in
let topology := op_startypeminuserrorstar in
let '(mesh_nodes, intermediary_nodes, accuser_nodes) :=
op_startypeminuserrorstar protocol node_exec topology base_port in
let all_nodes :=
OCaml.Stdlib.app mesh_nodes
(OCaml.Stdlib.app intermediary_nodes accuser_nodes) in
op_startypeminuserrorstar (op_startypeminuserrorstar state all_nodes)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let start_accuser {H I : Type} (nod : H) : I :=
let client := op_startypeminuserrorstar nod client_exec in
let acc := op_startypeminuserrorstar accuser_exec client nod in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(op_startypeminuserrorstar acc state))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt) in
op_startypeminuserrorstar
(op_startypeminuserrorstar accuser_nodes start_accuser)
(fun function_parameter =>
let 'tt := function_parameter in
let key_name := "b0" % string in
let baker {H I : Type} (nth : H) : I :=
let node := op_startypeminuserrorstar all_nodes nth in
let client := op_startypeminuserrorstar node client_exec in
let bak :=
op_startypeminuserrorstar client key_name
(op_startypeminuserrorstar (fst baker_0_account)) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state bak)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar (client, bak)) in
op_startypeminuserrorstar (baker 0)
(fun function_parameter =>
let '(client_0, baker_0) := function_parameter in
op_startypeminuserrorstar (baker 1)
(fun function_parameter =>
let '(client_1, baker_1) := function_parameter in
op_startypeminuserrorstar (baker 2)
(fun function_parameter =>
let '(client_2, baker_2) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
let pause {H I J : Type}
(force : option H) (msgs : I) : J :=
op_startypeminuserrorstar state force msgs in
let starting_level := 10 in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(Stdlib.List.init (Z.sub starting_level 1)
(* ❌ expected an argument *)
expected_argument (fun n => n))
(op_startypeminuserrorstar tt)
(fun pm =>
fun n =>
op_startypeminuserrorstar pm
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state
baker_0
(op_startypeminuserrorstar
"first bakes: [%d/%d]" % string
(Z.add n 1)
(Z.sub starting_level 1)))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8 all_nodes
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(pause None op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let transfer {H I J : Type}
(_msg : H) (client : I) : J :=
let dest :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar
(Tezos_protocol.bootstrap_accounts
protocol)) fst)
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
client
(cons "--wait" % string
(cons "none" % string
(cons "transfer" % string
(cons "1" % string
(cons "from" % string
(cons key_name
(cons "to" % string
(cons dest
(cons
"--fee" %
string
(cons
"0.05" %
string [])))))))))))
(fun res =>
op_startypeminuserrorstar state
op_startypeminuserrorstar) in
op_startypeminuserrorstar
(op_startypeminuserrorstar
intermediary_nodes
(fun x =>
op_startypeminuserrorstar state
x))
(fun function_parameter =>
let 'tt := function_parameter in
let kill_all_but {H I J : Type}
(nodes : H) (iths : I) : J :=
op_startypeminuserrorstar nodes
(fun ith =>
fun n =>
if
Stdlib.List.mem iths ith
op_startypeminuserrorstar
then
op_startypeminuserrorstar
tt
else
op_startypeminuserrorstar
state n) in
let kill_nth_node {H I : Type}
(nodes : list H) (nth : Z)
: I :=
op_startypeminuserrorstar state
(op_startypeminuserrorstar
"kill_nth_node" % string
(Stdlib.List.nth nodes nth))
in
let restart_nth_node {H I : Type}
(nodes : list H) (nth : Z)
: I :=
op_startypeminuserrorstar state
client_exec
(op_startypeminuserrorstar
"restart_nth_node" % string
(Stdlib.List.nth nodes nth))
in
let get_block_header {H I : Type}
(client : H) (block : variant)
: I :=
let path :=
op_startypeminuserrorstar
"/chains/main/blocks/%s/header"
% string
match block with
| Head => "head" % string
| Level i =>
op_startypeminuserrorstar
i
end in
op_startypeminuserrorstar state
client
(* ❌ Variants not supported *)
variant path in
op_startypeminuserrorstar
(kill_all_but mesh_nodes
(cons 0 []))
(fun function_parameter =>
let 'tt := function_parameter
in
let number_of_lonely_bakes :=
1 in
op_startypeminuserrorstar
(pause None
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(transfer
"node0 only alive" %
string client_0)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
number_of_lonely_bakes
(fun n =>
op_startypeminuserrorstar
state baker_0
(op_startypeminuserrorstar
"n0 only alive: %d"
% string n)))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(get_block_header
client_0
(* ❌ Variants not supported *)
variant)
(fun
_baking_0_header
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0
"self-endorsing"
% string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0
"baking self-endorsement"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(kill_nth_node
mesh_nodes
0)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(restart_nth_node
mesh_nodes
1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(transfer
"node1 only one alive"
%
string
client_1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
number_of_lonely_bakes
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
baker_1
"after transfer"
%
string))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(get_block_header
client_1
(* ❌ Variants not supported *)
variant)
(fun
_baking_1_header
=>
op_startypeminuserrorstar
(kill_nth_node
mesh_nodes
1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(pause
None
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
tt)
intermediary_nodes
(fun
prev
=>
fun
x
=>
op_startypeminuserrorstar
prev
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
client_exec
x)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
node_0 :=
op_startypeminuserrorstar
mesh_nodes
0
in
let
except_0
{H
:
Type}
(l
:
H
->
bool)
: (list
H)
->
list
H :=
Stdlib.List.filter
l
(* ❌ expected an argument *)
expected_argument
op_startypeminuserrorstar
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(except_0
mesh_nodes)
(op_startypeminuserrorstar
state
client_exec))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(pause
None
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_exec
node_0)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(pause
None
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
false)
accuser_nodes
(fun
prev_m
=>
fun
node
=>
op_startypeminuserrorstar
prev_m
(fun
prev
=>
let
client :=
op_startypeminuserrorstar
node
client_exec
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client
"double_baking_evidence"
%
string)
(fun
client_result
=>
op_startypeminuserrorstar
(orb
client_result
prev)))))
(fun
function_parameter
=>
match
function_parameter
with
|
true
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
false
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_2
(op_startypeminuserrorstar
"all at lvl %d"
%
string
(Z.add
(Z.add
starting_level
number_of_lonely_bakes)
1)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
10
(* ❌ Float constant 4. is approximated by the integer 4 *)
4
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
let
level :=
Z.add
(Z.add
starting_level
number_of_lonely_bakes)
2
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_2
level
"double_baking_evidence"
%
string)
(fun
function_parameter
=>
match
function_parameter
with
|
true
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
false
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(pause
None
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
"a couple more"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)))))))))))))))))))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_daemons_protocol_change.ml 230 errors
open Flextesa
open Internal_pervasives
open Console
let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt
let wait_for_voting_period ?level_within_period state ~client ~attempts period
=
let period_name = Tezos_protocol.Voting_period.to_string period in
let message =
sprintf
"Waiting for voting period: `%s`%s"
period_name
(Option.value_map
level_within_period
~default:""
~f:(sprintf " (and level-within-period ⥠%d)"))
in
Console.say state EF.(wf "%s" message)
>>= fun () ->
Helpers.wait_for state ~attempts ~seconds:10. (fun nth ->
Asynchronous_result.map_option level_within_period ~f:(fun lvl ->
Tezos_client.rpc
state
~client
`Get
~path:"/chains/main/blocks/head/metadata"
>>= fun json ->
try
let voting_period_position =
Jqo.field ~k:"level" json
|> Jqo.field ~k:"voting_period_position"
|> Jqo.get_int
in
return (voting_period_position >= lvl)
with e ->
failf
"Cannot get level.voting_period_position: %s"
(Printexc.to_string e))
>>= fun lvl_ok ->
Tezos_client.rpc
state
~client
`Get
~path:"/chains/main/blocks/head/votes/current_period_kind"
>>= function
| `String p when p = period_name && (lvl_ok = None || lvl_ok = Some true)
->
return (`Done (nth - 1))
| _ ->
Tezos_client.successful_client_cmd
state
~client
["show"; "voting"; "period"]
>>= fun res ->
Console.say
state
EF.(
desc_list
(wf "Voting period:")
[markdown_verbatim (String.concat ~sep:"\n" res#out)])
>>= fun () -> return (`Not_done message))
let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports
?generate_kiln_config ~node_exec ~client_exec ~first_baker_exec
~first_endorser_exec ~first_accuser_exec ~second_baker_exec
~second_endorser_exec ~second_accuser_exec ~admin_exec ~new_protocol_path
~extra_dummy_proposals_batch_size ~extra_dummy_proposals_batch_levels
~waiting_attempts test_variant () =
Helpers.System_dependencies.precheck
state
`Or_fail
~protocol_paths:[new_protocol_path]
~executables:
[ node_exec;
client_exec;
first_baker_exec;
first_endorser_exec;
first_accuser_exec;
second_baker_exec;
second_endorser_exec;
second_accuser_exec ]
>>= fun () ->
Test_scenario.network_with_protocol
?external_peer_ports
~protocol
~size
~base_port
state
~node_exec
~client_exec
>>= fun (nodes, protocol) ->
Tezos_client.rpc
state
~client:(Tezos_client.of_node (List.hd_exn nodes) ~exec:client_exec)
`Get
~path:"/chains/main/chain_id"
>>= fun chain_id_json ->
let network_id =
match chain_id_json with `String s -> s | _ -> assert false
in
let accusers =
List.concat_map nodes ~f:(fun node ->
let client = Tezos_client.of_node node ~exec:client_exec in
[ Tezos_daemon.accuser_of_node
~exec:first_accuser_exec
~client
node
~name_tag:"first";
Tezos_daemon.accuser_of_node
~exec:second_accuser_exec
~client
node
~name_tag:"second" ])
in
List_sequential.iter accusers ~f:(fun acc ->
Running_processes.start state (Tezos_daemon.process acc ~state)
>>= fun _ -> return ())
>>= fun () ->
let keys_and_daemons =
let pick_a_node_and_client idx =
match List.nth nodes ((1 + idx) mod List.length nodes) with
| Some node ->
(node, Tezos_client.of_node node ~exec:client_exec)
| None ->
assert false
in
Tezos_protocol.bootstrap_accounts protocol
|> List.filter_mapi ~f:(fun idx acc ->
let (node, client) = pick_a_node_and_client idx in
let key = Tezos_protocol.Account.name acc in
if List.mem ~equal:String.equal no_daemons_for key then None
else
Some
( acc,
client,
[ Tezos_daemon.baker_of_node
~exec:first_baker_exec
~client
node
~key
~name_tag:"first";
Tezos_daemon.baker_of_node
~exec:second_baker_exec
~client
~name_tag:"second"
node
~key;
Tezos_daemon.endorser_of_node
~exec:first_endorser_exec
~name_tag:"first"
~client
node
~key;
Tezos_daemon.endorser_of_node
~exec:second_endorser_exec
~name_tag:"second"
~client
node
~key ] ))
in
List_sequential.iter keys_and_daemons ~f:(fun (acc, client, daemons) ->
Tezos_client.bootstrapped ~state client
>>= fun () ->
let (key, priv) = Tezos_protocol.Account.(name acc, private_key acc) in
Tezos_client.import_secret_key ~state client key priv
>>= fun () ->
say
state
EF.(
desc_list
(haf "Registration-as-delegate:")
[ desc (af "Client:") (af "%S" client.Tezos_client.id);
desc (af "Key:") (af "%S" key) ])
>>= fun () ->
Tezos_client.register_as_delegate ~state client key
>>= fun () ->
say
state
EF.(
desc_list
(haf "Starting daemons:")
[ desc (af "Client:") (af "%S" client.Tezos_client.id);
desc (af "Key:") (af "%S" key) ])
>>= fun () ->
List_sequential.iter daemons ~f:(fun daemon ->
Running_processes.start state (Tezos_daemon.process daemon ~state)
>>= fun _ -> return ()))
>>= fun () ->
let client_0 =
Tezos_client.of_node (List.nth_exn nodes 0) ~exec:client_exec
in
let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes
@ [secret_keys state ~protocol]
@ arbitrary_commands_for_each_and_all_clients
state
~make_admin
~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
(*
For each node we try to see if the node knows about the protocol,
if it does we're good, if not we inject it.
This is because `inject` fails when the node already knows a protocol.
*)
List.fold ~init:(return None) nodes ~f:(fun prevm nod ->
prevm
>>= fun _ ->
System.read_file state (new_protocol_path // "TEZOS_PROTOCOL")
>>= fun protocol ->
( try return Jqo.(of_string protocol |> field ~k:"hash" |> get_string)
with e ->
failf
"Cannot parse %s/TEZOS_PROTOCOL: %s"
new_protocol_path
(Printexc.to_string e) )
>>= fun hash ->
let client = Tezos_client.of_node ~exec:client_exec nod in
Tezos_client.rpc state ~client `Get ~path:"/protocols"
>>= fun protocols ->
match protocols with
| `A l
when List.exists l ~f:(function `String h -> h = hash | _ -> false) ->
Console.say
state
EF.(
wf
"Node `%s` already knows protocol `%s`."
nod.Tezos_node.id
hash)
>>= fun () -> return (Some hash)
| _ ->
let admin = make_admin client in
Tezos_admin_client.inject_protocol
admin
state
~path:new_protocol_path
>>= fun (_, new_protocol_hash) ->
( if new_protocol_hash = hash then
Console.say
state
EF.(
wf
"Injected protocol `%s` in `%s`"
new_protocol_hash
nod.Tezos_node.id)
else
failf
"Injecting protocol %s failed (â %s)"
new_protocol_hash
hash )
>>= fun () -> return (Some hash))
>>= fun prot_opt ->
( match prot_opt with
| Some s ->
return s
| None ->
failf "protocol injection problem?" )
>>= fun new_protocol_hash ->
Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config ->
Kiln.Configuration_directory.generate
state
kiln_config
~peers:(List.map nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port))
~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol)
~nodes:
(List.map nodes ~f:(fun {Tezos_node.rpc_port; _} ->
sprintf "http://localhost:%d" rpc_port))
~bakers:
(List.map
protocol.Tezos_protocol.bootstrap_accounts
~f:(fun (account, _) ->
Tezos_protocol.Account.(name account, pubkey_hash account)))
~network_string:network_id
~node_exec
~client_exec
~protocol_execs:
[ ( protocol.Tezos_protocol.hash,
first_baker_exec,
first_endorser_exec );
(new_protocol_hash, second_baker_exec, second_endorser_exec) ]
>>= fun () ->
let msg =
EF.(
desc
(shout "Kiln-Configuration DONE")
(wf "Kiln was configured at `%s`" kiln_config.path))
in
Console.say state msg >>= fun () -> return msg)
>>= fun kiln_info_opt ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:waiting_attempts
~seconds:10.
nodes
(* TODO: wait for /chains/main/blocks/head/votes/listings to be
non-empty instead of counting blocks *)
(`At_least protocol.Tezos_protocol.blocks_per_voting_period)
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.
[ wf "Test becomes interactive.";
Option.value kiln_info_opt ~default:(wf "");
wf "Please type `q` to start a voting/protocol-change period." ]
~force:true
>>= fun () ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Proposal
~level_within_period:3
>>= fun _ ->
let submit_prop acc client hash =
Tezos_client.successful_client_cmd
state
~client
[ "submit";
"proposals";
"for";
Tezos_protocol.Account.name acc;
hash;
"--force" ]
>>= fun _ ->
Console.sayf
state
Fmt.(
fun ppf () ->
pf ppf "%s voted for %s" (Tezos_protocol.Account.name acc) hash)
in
List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
submit_prop acc client new_protocol_hash)
>>= fun () ->
let make_dummy_protocol_hashes t tag =
List.map
(List.init extra_dummy_proposals_batch_size ~f:(fun s ->
sprintf "proto-%s-%d" tag s))
~f:(fun s ->
(t, Tezos_crypto.Protocol_hash.(hash_string [s] |> to_b58check)))
in
let extra_dummy_protocols =
List.bind extra_dummy_proposals_batch_levels ~f:(fun l ->
make_dummy_protocol_hashes l (sprintf "%d" l))
in
Console.say
state
EF.(
wf
"Going to also vote for %s"
(String.concat ~sep:", " (List.map extra_dummy_protocols ~f:snd)))
>>= fun () ->
List_sequential.iteri
extra_dummy_protocols
~f:(fun nth (level, proto_hash) ->
match List.nth keys_and_daemons (nth / 19) with
| None ->
failf "Too many dummy protocols Vs available voting power (%d)" nth
| Some (acc, client, _) ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Proposal
~level_within_period:level
>>= fun _ -> submit_prop acc client proto_hash)
>>= fun () ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Testing_vote
>>= fun _ ->
List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
Tezos_client.successful_client_cmd
state
~client
[ "submit";
"ballot";
"for";
Tezos_protocol.Account.name acc;
new_protocol_hash;
"yea" ]
>>= fun _ ->
Console.sayf
state
Fmt.(
fun ppf () ->
pf
ppf
"%s voted Yea to test %s"
(Tezos_protocol.Account.name acc)
new_protocol_hash))
>>= fun () ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Promotion_vote
>>= fun _ ->
let protocol_switch_will_happen =
match test_variant with
| `Full_upgrade ->
true
| `Nay_for_promotion ->
false
in
List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
Tezos_client.successful_client_cmd
state
~client
[ "submit";
"ballot";
"for";
Tezos_protocol.Account.name acc;
new_protocol_hash;
(if protocol_switch_will_happen then "yea" else "nay") ]
>>= fun _ ->
Console.sayf
state
Fmt.(
fun ppf () ->
pf
ppf
"%s voted Yea to promote %s"
(Tezos_protocol.Account.name acc)
new_protocol_hash))
>>= fun () ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Proposal
>>= fun _ ->
Tezos_client.successful_client_cmd
state
~client:client_0
["show"; "voting"; "period"]
>>= fun res ->
let protocol_to_wait_for =
if protocol_switch_will_happen then new_protocol_hash
else protocol.Tezos_protocol.hash
in
Helpers.wait_for state ~attempts:waiting_attempts ~seconds:4. (fun _ ->
Console.say state EF.(wf "Checking actual protocol transition")
>>= fun () ->
Tezos_client.rpc
state
~client:client_0
`Get
~path:"/chains/main/blocks/head/metadata"
>>= fun json ->
( try Jqo.field ~k:"protocol" json |> Jqo.get_string |> return
with e -> failf "Cannot parse metadata: %s" (Printexc.to_string e) )
>>= fun proto_hash ->
if proto_hash <> protocol_to_wait_for then
return
(`Not_done
(sprintf
"Protocol not done: %s Vs %s"
proto_hash
protocol_to_wait_for))
else return (`Done ()))
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.
[ wf
"Test finished, protocol is now %s, things should keep baking."
protocol_to_wait_for;
markdown_verbatim (String.concat ~sep:"\n" res#out) ]
~force:true
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
let variants =
[ ( "full-upgrade",
`Full_upgrade,
"Go through the whole voting process and do the protocol change." );
( "nay-for-promotion",
`Nay_for_promotion,
"Go through the whole voting process but vote Nay at the last period \
and hence stay on the same protocol." ) ]
in
Test_command_line.Run_command.make
~pp_error
( pure
(fun size
base_port
(`Attempts waiting_attempts)
(`External_peers external_peer_ports)
(`No_daemons_for no_daemons_for)
protocol
node_exec
client_exec
admin_exec
first_baker_exec
first_endorser_exec
first_accuser_exec
second_baker_exec
second_endorser_exec
second_accuser_exec
(`Protocol_path new_protocol_path)
(`Extra_dummy_proposals_batch_size
extra_dummy_proposals_batch_size)
(`Extra_dummy_proposals_batch_levels
extra_dummy_proposals_batch_levels)
generate_kiln_config
test_variant
state
->
let actual_test =
run
state
~size
~base_port
~protocol
~node_exec
~client_exec
~first_baker_exec
~first_endorser_exec
~first_accuser_exec
~second_baker_exec
~second_endorser_exec
~second_accuser_exec
~admin_exec
?generate_kiln_config
~external_peer_ports
~no_daemons_for
~new_protocol_path
test_variant
~waiting_attempts
~extra_dummy_proposals_batch_size
~extra_dummy_proposals_batch_levels
in
(state, Interactive_test.Pauser.run_test ~pp_error state actual_test))
$ Arg.(
value & opt int 5
& info ["size"; "S"] ~doc:"Set the size of the network.")
$ Arg.(
value & opt int 20_000
& info ["base-port"; "P"] ~doc:"Base port number to build upon.")
$ Arg.(
pure (fun n -> `Attempts n)
$ value
(opt
int
60
(info
["waiting-attempts"]
~doc:
"Number of attempts done while waiting for voting periods")))
$ Arg.(
pure (fun l -> `External_peers l)
$ value
(opt_all
int
[]
(info
["add-external-peer-port"]
~docv:"PORT-NUMBER"
~doc:"Add $(docv) to the peers of the network nodes.")))
$ Arg.(
pure (fun l -> `No_daemons_for l)
$ value
(opt_all
string
[]
(info
["no-daemons-for"]
~docv:"ACCOUNT-NAME"
~doc:"Do not start daemons for $(docv).")))
$ Tezos_protocol.cli_term ()
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Tezos_executable.cli_term `Admin "tezos"
$ Tezos_executable.cli_term `Baker "first"
$ Tezos_executable.cli_term `Endorser "first"
$ Tezos_executable.cli_term `Accuser "first"
$ Tezos_executable.cli_term `Baker "second"
$ Tezos_executable.cli_term `Endorser "second"
$ Tezos_executable.cli_term `Accuser "second"
$ Arg.(
pure (fun p -> `Protocol_path p)
$ required
(pos
0
(some string)
None
(info
[]
~doc:"The protocol to inject and vote on."
~docv:"PROTOCOL-PATH")))
$ Arg.(
pure (fun l -> `Extra_dummy_proposals_batch_size l)
$ value
(opt
int
0
(info
["extra-dummy-proposals-batch-size"]
~docv:"NUMBER"
~doc:"Submit $(docv) extra proposals per batch.")))
$ Arg.(
pure (fun x -> `Extra_dummy_proposals_batch_levels x)
$ value
(opt
(list ~sep:',' int)
[]
(info
["extra-dummy-proposals-batch-levels"]
~docv:"NUMBER"
~doc:
"Set the levels within the proposal period where batches \
of extra proposals appear, e.g. `3,5,7`.")))
$ Kiln.Configuration_directory.cli_term ()
$ Arg.(
let doc =
sprintf
"Which variant of the test to run (one of {%s})"
( List.map ~f:(fun (n, _, _) -> n) variants
|> String.concat ~sep:", " )
in
value
(opt
(enum (List.map variants ~f:(fun (n, v, _) -> (n, v))))
`Full_upgrade
(info ["test-variant"] ~doc)))
$ Test_command_line.cli_state ~name:"daemons-upgrade" () )
(let doc =
"Vote and Protocol-upgrade with bakers, endorsers, and accusers."
in
let man : Manpage.block list =
[ `S "DAEMONS-UPGRADE TEST";
`P
"This test builds and runs a sandbox network to do a full voting \
round followed by a protocol change while all the daemons.";
`P
(sprintf
"There are for now %d variants (see option `--test-variant`):"
(List.length variants));
`Blocks
(List.concat_map variants ~f:(fun (n, _, desc) ->
[`Noblank; `P (sprintf "* `%s`: %s" n desc)]));
`P "The test is interactive-only:";
`Blocks
(List.concat_mapi
~f:(fun i s -> [`Noblank; `P (sprintf "%d) %s" (i + 1) s)])
[ "It starts a sandbox assuming the protocol of the `--first-*` \
executables (use the `--protocol-hash` option to make sure \
it matches).";
"An interactive pause is done to let the user play with the \
`first` protocol.";
"Once the user quits the prompt (`q` or `quit` command), a \
full voting round happens with a single proposal: the one at \
`PROTOCOL-PATH` (which should be the one understood by the \
`--second-*` executables).";
"Once the potential protocol switch has happened (and been \
verified), the test re-enters an interactive prompt to let \
the user play with the protocol (the first or second one, \
depending on the `--test-variant` option)." ]) ]
in
info "daemons-upgrade" ~man ~doc)
src/bin_sandbox/command_daemons_protocol_change.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition failf {A B : Type} (fmt : A) : B :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant) fmt.
Definition wait_for_voting_period {A B C D E F : Type}
(level_within_period : option A) (state : B) (client : C) (attempts : D)
(period : E) : F :=
let period_name := op_startypeminuserrorstar period in
let message :=
op_startypeminuserrorstar "Waiting for voting period: `%s`%s" % string
period_name
(op_startypeminuserrorstar level_within_period "" % string
(op_startypeminuserrorstar " (and level-within-period ≥ %d)" % string))
in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state attempts
(* ❌ Float constant 10. is approximated by the integer 10 *)
10
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar level_within_period
(fun lvl =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/blocks/head/metadata" % string)
(fun json =>
(* ❌ Try-with are not handled *)
try
(let voting_period_position :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar "level" % string json)
(op_startypeminuserrorstar
"voting_period_position" % string))
op_startypeminuserrorstar in
op_startypeminuserrorstar
(OCaml.Stdlib.ge voting_period_position lvl)))))
(fun lvl_ok =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/votes/current_period_kind" % string)
(fun function_parameter =>
match function_parameter with
| String p =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| _ =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "show" % string
(cons "voting" % string (cons "period" % string []))))
(fun res =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
end)))).
Definition run {A B C D E F G H I J K L M : Type}
(state : A) (protocol : B) (size : C) (base_port : D) (no_daemons_for : E)
(external_peer_ports : option F) (generate_kiln_config : option G)
(node_exec : H) (client_exec : H) (first_baker_exec : H)
(first_endorser_exec : H) (first_accuser_exec : H) (second_baker_exec : H)
(second_endorser_exec : H) (second_accuser_exec : H) (admin_exec : I)
(new_protocol_path : J) (extra_dummy_proposals_batch_size : Z)
(extra_dummy_proposals_batch_levels : K) (waiting_attempts : L)
(test_variant : variant) (function_parameter : unit) : M :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(* ❌ Variants not supported *)
variant (cons new_protocol_path [])
(cons node_exec
(cons client_exec
(cons first_baker_exec
(cons first_endorser_exec
(cons first_accuser_exec
(cons second_baker_exec
(cons second_endorser_exec (cons second_accuser_exec [])))))))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar external_peer_ports protocol size base_port
state node_exec client_exec)
(fun function_parameter =>
let '(nodes, protocol) := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(op_startypeminuserrorstar (op_startypeminuserrorstar nodes)
client_exec)
(* ❌ Variants not supported *)
variant "/chains/main/chain_id" % string)
(fun chain_id_json =>
let network_id :=
match chain_id_json with
| String s => s
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
let accusers :=
op_startypeminuserrorstar nodes
(fun node =>
let client := op_startypeminuserrorstar node client_exec in
cons
(op_startypeminuserrorstar first_accuser_exec client node
"first" % string)
(cons
(op_startypeminuserrorstar second_accuser_exec client
node "second" % string) [])) in
op_startypeminuserrorstar
(op_startypeminuserrorstar accusers
(fun acc =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(op_startypeminuserrorstar acc state))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt)))
(fun function_parameter =>
let 'tt := function_parameter in
let keys_and_daemons :=
let pick_a_node_and_client {N O : Type} (idx : Z) : N * O :=
match
Stdlib.List.nth nodes
(Z.modulo (Z.add 1 idx) (OCaml.List.length nodes))
with
| Some node =>
(node, (op_startypeminuserrorstar node client_exec))
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar protocol)
(op_startypeminuserrorstar
(fun idx =>
fun acc =>
let '(node, client) := pick_a_node_and_client idx in
let key := op_startypeminuserrorstar acc in
if
Stdlib.List.mem no_daemons_for key
Stdlib.String.equal then
None
else
Some
(acc, client,
(cons
(op_startypeminuserrorstar first_baker_exec
client node key "first" % string)
(cons
(op_startypeminuserrorstar
second_baker_exec client
"second" % string node key)
(cons
(op_startypeminuserrorstar
first_endorser_exec "first" % string
client node key)
(cons
(op_startypeminuserrorstar
second_endorser_exec
"second" % string client node key)
[]))))))) in
op_startypeminuserrorstar
(op_startypeminuserrorstar keys_and_daemons
(fun function_parameter =>
let '(acc, client, daemons) := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client)
(fun function_parameter =>
let 'tt := function_parameter in
let '(key, priv) := op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client key priv)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
key)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar daemons
(fun daemon =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(op_startypeminuserrorstar
daemon state))
(fun function_parameter =>
let '_ := function_parameter
in
op_startypeminuserrorstar tt)))))))))
(fun function_parameter =>
let 'tt := function_parameter in
let client_0 :=
op_startypeminuserrorstar
(op_startypeminuserrorstar nodes 0) client_exec in
let make_admin := op_startypeminuserrorstar admin_exec in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar None) nodes
(fun prevm =>
fun nod =>
op_startypeminuserrorstar prevm
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(op_startypeminuserrorstar
new_protocol_path
"TEZOS_PROTOCOL" % string))
(fun protocol =>
op_startypeminuserrorstar
(* ❌ Try-with are not handled *)
(try
(op_startypeminuserrorstar
op_startypeminuserrorstar))
(fun hash =>
let client :=
op_startypeminuserrorstar
client_exec nod in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
client
(* ❌ Variants not supported *)
variant "/protocols" % string)
(fun protocols =>
match protocols with
| A l =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(Some hash))
| _ =>
let admin := make_admin client
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
admin state
new_protocol_path)
(fun function_parameter =>
let
'(_, new_protocol_hash) :=
function_parameter in
op_startypeminuserrorstar
(if
equiv_decb
new_protocol_hash hash
then
op_startypeminuserrorstar
state
op_startypeminuserrorstar
else
failf
"Injecting protocol %s failed (≠ %s)"
% string
new_protocol_hash hash)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(Some hash)))
end))))))
(fun prot_opt =>
op_startypeminuserrorstar
match prot_opt with
| Some s => op_startypeminuserrorstar s
| None =>
failf "protocol injection problem?" % string
end
(fun new_protocol_hash =>
op_startypeminuserrorstar
(op_startypeminuserrorstar generate_kiln_config
(fun kiln_config =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
kiln_config op_startypeminuserrorstar
(op_startypeminuserrorstar state
protocol) op_startypeminuserrorstar
(List.map
(Tezos_protocol.bootstrap_accounts
protocol)
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '(account, _) :=
function_parameter in
op_startypeminuserrorstar))
network_id node_exec client_exec
(cons
((Tezos_protocol.hash protocol),
first_baker_exec,
first_endorser_exec)
(cons
(new_protocol_hash,
second_baker_exec,
second_endorser_exec) [])))
(fun function_parameter =>
let 'tt := function_parameter in
let msg := op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state msg)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar msg))))
(fun kiln_info_opt =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
waiting_attempts
(* ❌ Float constant 10. is approximated by the integer 10 *)
10 nodes
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar true)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(wait_for_voting_period (Some 3)
state client_0 waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let '_ := function_parameter in
let submit_prop {N O P : Type}
(acc : N) (client : O) (hash :
string) : P :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
state client
(cons "submit" % string
(cons "proposals" % string
(cons "for" % string
(cons
(op_startypeminuserrorstar
acc)
(cons hash
(cons
"--force" %
string [])))))))
(fun function_parameter =>
let '_ := function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
keys_and_daemons
(fun function_parameter =>
let '(acc, client, _) :=
function_parameter in
submit_prop acc client
new_protocol_hash))
(fun function_parameter =>
let 'tt := function_parameter
in
let make_dummy_protocol_hashes
{N O P : Type}
(t : N) (tag : O)
: (list (Z -> P)) ->
list (list P) :=
List.map
(Stdlib.List.init
extra_dummy_proposals_batch_size
(* ❌ expected an argument *)
expected_argument
(fun s =>
op_startypeminuserrorstar
"proto-%s-%d" %
string tag s))
(* ❌ expected an argument *)
expected_argument
(fun s =>
(t,
op_startypeminuserrorstar))
in
let extra_dummy_protocols :=
op_startypeminuserrorstar
extra_dummy_proposals_batch_levels
(fun l =>
make_dummy_protocol_hashes
l
(op_startypeminuserrorstar
"%d" % string l)) in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
extra_dummy_protocols
(fun nth =>
fun
function_parameter
=>
let
'(level,
proto_hash) :=
function_parameter
in
match
Stdlib.List.nth
keys_and_daemons
(Z.div nth 19)
with
| None =>
failf
"Too many dummy protocols Vs available voting power (%d)"
% string nth
|
Some
(acc, client,
_) =>
op_startypeminuserrorstar
(wait_for_voting_period
(Some level)
state
client_0
waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let '_ :=
function_parameter
in
submit_prop
acc client
proto_hash)
end))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_voting_period
None state
client_0
waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let '_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
keys_and_daemons
(fun
function_parameter
=>
let
'(acc,
client,
_) :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(op_startypeminuserrorstar
acc)
(cons
new_protocol_hash
(cons
"yea"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_voting_period
None state
client_0
waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let '_ :=
function_parameter
in
let
protocol_switch_will_happen :=
match
test_variant
with
|
Full_upgrade
=>
true
|
Nay_for_promotion
=>
false
end in
op_startypeminuserrorstar
(op_startypeminuserrorstar
keys_and_daemons
(fun
function_parameter
=>
let
'(acc,
client,
_) :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(op_startypeminuserrorstar
acc)
(cons
new_protocol_hash
(cons
(if
protocol_switch_will_happen
then
"yea"
%
string
else
"nay"
%
string)
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_voting_period
None
state
client_0
waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_0
(cons
"show"
%
string
(cons
"voting"
%
string
(cons
"period"
%
string
[]))))
(fun
res
=>
let
protocol_to_wait_for :=
if
protocol_switch_will_happen
then
new_protocol_hash
else
Tezos_protocol.hash
protocol
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
waiting_attempts
(* ❌ Float constant 4. is approximated by the integer 4 *)
4
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_0
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/metadata"
%
string)
(fun
json
=>
op_startypeminuserrorstar
(* ❌ Try-with are not handled *)
(try
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar
"protocol"
%
string
json)
op_startypeminuserrorstar)
op_startypeminuserrorstar))
(fun
proto_hash
=>
if
nequiv_decb
proto_hash
protocol_to_wait_for
then
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
else
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant)))))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar
true))))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_ledger_baking.ml 255 errors
open Flextesa
open Internal_pervasives
let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt
let ledger_prompt_notice state ~ef ?(button = `Checkmark) () =
let button_str =
match button with
| `Checkmark ->
"â"
| `X ->
"â"
| `Both ->
"â and â at the same time"
in
Console.say
state
EF.(
desc
(shout "Ledger-prompt")
(list [ef; wf "Press %s on the ledger." button_str]))
let assert_failure state msg f () =
Console.say state EF.(wf "Asserting %s" msg)
>>= fun () ->
Asynchronous_result.bind_on_error
(f () >>= fun _ -> return `Worked)
~f:(fun ~result:_ _ -> return `Didn'tWork)
>>= function `Worked -> failf "%s" msg | `Didn'tWork -> return ()
let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt
let assert_ a = if a then return () else failf "Assertion failed"
let assert_eq to_string ~expected ~actual =
if expected = actual then return ()
else
failf
"Assertion failed: expected %s but got %s"
(to_string expected)
(to_string actual)
let rec ask state ef =
Console.say state EF.(list [ef; wf " (y/n)?"])
>>= fun () ->
System_error.catch Lwt_io.read_char Lwt_io.stdin
>>= function
| 'y' | 'Y' -> return true | 'n' | 'N' -> return false | _ -> ask state ef
let ask_assert state ef () = ask state ef >>= fun b -> assert_ b
let with_ledger_prompt state message expectation ~f =
ledger_prompt_notice
state
()
~button:(match expectation with `Succeeds -> `Checkmark | `Fails -> `X)
~ef:
EF.(
list
[ message;
wf "\n\n";
wf
( match expectation with
| `Succeeds ->
">> ACCEPT THIS <<"
| `Fails ->
">> REJECT THIS <<" ) ])
>>= fun () ->
match expectation with
| `Succeeds ->
f () >>= fun _ -> Console.say state EF.(wf "> Got response: ACCEPTED")
| `Fails ->
assert_failure state "expected failure" f ()
>>= fun () -> Console.say state EF.(wf "> Got response: REJECTED")
let with_ledger_test_reject_and_succeed state ef f =
with_ledger_prompt state ef `Fails ~f
>>= fun () -> with_ledger_prompt state ef `Succeeds ~f
let assert_hwms state ~client ~uri ~main ~test =
Console.say
state
EF.(wf "Asserting main HWM = %d and test HWM = %d" main test)
>>= fun () ->
Tezos_client.Ledger.get_hwm state ~client ~uri
>>= fun {main = main_actual; test = test_actual; _} ->
assert_eq string_of_int ~actual:main_actual ~expected:main
>>= fun () -> assert_eq string_of_int ~actual:test_actual ~expected:test
let get_chain_id state ~client =
Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id"
>>= (function
| `String x ->
return x
| _ ->
failf "Failed to parse chain_id JSON from node")
>>= fun chain_id_string ->
return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string)
let get_head_block_hash state ~client () =
Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash"
>>= function
| `String x ->
return x
| _ ->
failf "Failed to parse block hash JSON from node"
let forge_endorsement state ~client ~chain_id ~level () =
get_head_block_hash state ~client ()
>>= fun branch ->
let json =
`O
[ ("branch", `String branch);
( "contents",
`A
[ `O
[ ("kind", `String "endorsement");
("level", `Float (float_of_int level)) ] ] ) ]
in
Tezos_client.rpc
state
~client
~path:"/chains/main/blocks/head/helpers/forge/operations"
(`Post (Ezjsonm.to_string json))
>>= function
| `String operation_bytes ->
let endorsement_magic_byte = "02" in
return
( endorsement_magic_byte
^ (chain_id |> Tezos_crypto.Chain_id.to_hex |> Hex.show)
^ operation_bytes )
| _ ->
failf "Failed to forge operation or parse result"
let forge_delegation state ~client ~src ~dest ?(fee = 0.00126) () =
get_head_block_hash state ~client ()
>>= fun branch ->
let json =
`O
[ ("branch", `String branch);
( "contents",
`A
[ `O
[ ("kind", `String "delegation");
("source", `String src);
( "fee",
`String (string_of_int (int_of_float (fee *. 1000000.))) );
("counter", `String (string_of_int 30713));
("gas_limit", `String (string_of_int 10100));
("delegate", `String dest);
("storage_limit", `String (string_of_int 277)) ] ] ) ]
in
Tezos_client.rpc
state
~client
~path:"/chains/main/blocks/head/helpers/forge/operations"
(`Post (Ezjsonm.to_string json))
>>= function
| `String operation_bytes ->
let magic_byte = "03" in
return (magic_byte ^ operation_bytes)
| _ ->
failf "Failed to forge operation or parse result"
let sign state ~client ~bytes () =
Tezos_client.successful_client_cmd
state
~client:client.Tezos_client.Keyed.client
["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name]
>>= fun _ -> return ()
let originate_account_from state ~client ~account =
let orig_account_name =
Tezos_protocol.Account.name account ^ "-originated-account"
in
Tezos_client.successful_client_cmd
state
~client
[ "originate";
"account";
orig_account_name;
"for";
Tezos_protocol.Account.name account;
"transferring";
string_of_int 1000;
"from";
Tezos_protocol.Account.name account;
"--burn-cap";
string_of_float 0.257 ]
>>= fun _ -> return orig_account_name
let setup_baking_ledger state uri ~client ~protocol =
Console.say state EF.(wf "Setting up the ledger device %S" uri)
>>= fun () ->
let key_name = "ledgered" in
let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in
let assert_baking_key x () =
let to_string = function Some x -> x | None -> "<none>" in
Console.say
state
EF.(wf "Asserting that the authorized key is %s" (to_string x))
>>= fun () ->
Tezos_client.Ledger.get_authorized_key state ~client ~uri
>>= fun auth_key -> assert_eq to_string ~expected:x ~actual:auth_key
in
Tezos_client.Ledger.deauthorize_baking state ~client ~uri
(* TODO: The following assertion doesn't confirm anything if the ledger was already not authorized to bake. *)
>>= assert_baking_key None
>>= fun () ->
Tezos_client.Ledger.show_ledger state ~client ~uri
>>= fun account ->
with_ledger_test_reject_and_succeed
state
EF.(
wf
"Importing %S in client `%s`. The ledger should be prompting for \
acknowledgment to provide the public key of %s"
uri
client.Tezos_client.id
(Tezos_protocol.Account.pubkey_hash account))
(fun () ->
Tezos_client.Keyed.initialize state baker >>= fun _ -> return ())
>>= assert_failure state "baking before setup should fail" (fun () ->
Tezos_client.Keyed.bake state baker "Baked by ledger")
>>= assert_failure state "endorsing before setup should fail" (fun () ->
Tezos_client.Keyed.endorse state baker "Endorsed by ledger")
>>= fun () ->
let test_invalid_delegations () =
let ledger_pkh = Tezos_protocol.Account.pubkey_hash account in
let other_pkh =
Tezos_protocol.Account.pubkey_hash
(fst (List.last_exn protocol.Tezos_protocol.bootstrap_accounts))
in
let cases =
[ (ledger_pkh, other_pkh, "ledger to another account");
(other_pkh, ledger_pkh, "another account to ledger");
(other_pkh, other_pkh, "another account to another account") ]
in
List_sequential.iter cases ~f:(fun (src, dest, msg) ->
forge_delegation state ~client ~src ~dest ()
>>= fun forged_delegation_bytes ->
assert_failure
state
(sprintf
"signing a delegation from %s (%s to %s) should fail"
msg
src
dest)
(sign state ~client:baker ~bytes:forged_delegation_bytes)
())
in
test_invalid_delegations ()
>>= fun () ->
with_ledger_test_reject_and_succeed
state
EF.(
wf
"Setting up %S for baking.\n\
Address: %S\n\
Chain: mainnet\n\
Main Chain HWM: 0\n\
Test Chain HWM: 0"
uri
(Tezos_protocol.Account.pubkey_hash account))
(fun () ->
Tezos_client.successful_client_cmd
state
~client
[ "setup";
"ledger";
"to";
"bake";
"for";
key_name;
"--main-hwm";
"0";
"--test-hwm";
"0" ])
>>= assert_failure
state
"signing a 'Withdraw delegate' operation in Baking App should fail"
(fun () ->
Tezos_client.successful_client_cmd
state
~client
[ "--wait";
"none";
"withdraw";
"delegate";
"from";
Tezos_protocol.Account.pubkey_hash account ])
>>= assert_baking_key (Some uri)
>>= test_invalid_delegations
>>= fun () -> return (baker, account)
let run state ~protocol ~node_exec ~client_exec ~admin_exec ~size ~base_port
~uri ~enable_deterministic_nonce_tests () =
Helpers.clear_root state
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[af "Ready to start"; af "Root path deleted."]
>>= fun () ->
let ledger_client = Tezos_client.no_node_client ~exec:client_exec in
Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri
>>= fun ledger_account ->
let protocol =
let open Tezos_protocol in
{
protocol with
time_between_blocks = [1; 2];
bootstrap_accounts =
(ledger_account, 1_000_000_000_000L) :: protocol.bootstrap_accounts;
}
in
let other_baker_account =
fst (List.nth_exn protocol.Tezos_protocol.bootstrap_accounts 1)
in
Test_scenario.network_with_protocol
~protocol
~size
~base_port
state
~node_exec
~client_exec
>>= fun (nodes, protocol) ->
let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
@ arbitrary_commands_for_each_and_all_clients
state
~make_admin
~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
>>= fun () ->
let client n =
Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
in
Tezos_client.successful_client_cmd
state
~client:(client 0)
Tezos_protocol.Account.
[ "import";
"secret";
"key";
name other_baker_account;
private_key other_baker_account ]
>>= fun _ ->
Tezos_client.successful_client_cmd
state
~client:(client 0)
Tezos_protocol.Account.["bake"; "for"; name other_baker_account]
>>= fun _ ->
let assert_hwms_ ~main ~test () =
assert_hwms state ~client:(client 0) ~uri ~main ~test
in
let set_hwm_ level () =
with_ledger_prompt
state
EF.(wf "Setting HWM to %d" level)
`Succeeds
~f:(fun () ->
Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level)
in
get_chain_id state ~client:(client 0)
>>= fun chain_id ->
setup_baking_ledger state uri ~client:(client 0) ~protocol
>>= fun (baker, ledger_account) ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.
[ arbitrary_command_on_all_clients
state
~command_names:["baker"]
~make_admin
~clients:[baker.Tezos_client.Keyed.client] ] ;
let bake () = Tezos_client.Keyed.bake state baker "Baked by ledger" in
let endorse () =
Tezos_client.Keyed.endorse state baker "Endorsed by ledger"
in
let ask_hwm ~main ~test () =
assert_hwms_ ~main ~test ()
>>= ask_assert
state
EF.(wf "Is 'Chain' = %S and 'Last Block Level' = %d" "mainnet" main)
in
( if enable_deterministic_nonce_tests then
(* Test determinism of nonces *)
Tezos_client.Keyed.generate_nonce state baker "this"
>>= fun thisNonce1 ->
Tezos_client.Keyed.generate_nonce state baker "that"
>>= fun thatNonce1 ->
Tezos_client.Keyed.generate_nonce state baker "this"
>>= fun thisNonce2 ->
Tezos_client.Keyed.generate_nonce state baker "that"
>>= fun thatNonce2 ->
assert_eq (fun x -> x) ~expected:thisNonce1 ~actual:thisNonce2
>>= fun () ->
assert_eq (fun x -> x) ~expected:thatNonce1 ~actual:thatNonce2
>>= fun () -> assert_ (thisNonce1 <> thatNonce1)
else return () )
>>= fun () ->
assert_failure
state
"originating an account from the Tezos Baking app should fail"
(fun () ->
originate_account_from state ~client:(client 0) ~account:ledger_account
>>= fun _ -> return ())
()
>>= fun () ->
let fee = 0.00126 in
let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
forge_delegation
state
~client:(client 0)
()
~src:ledger_pkh
~dest:ledger_pkh
~fee
>>= fun forged_delegation_bytes ->
with_ledger_test_reject_and_succeed
state
EF.(wf "Self delegating address %s with fee %f" ledger_pkh fee)
(sign state ~client:baker ~bytes:forged_delegation_bytes)
>>= bake >>= ask_hwm ~main:3 ~test:0
>>= fun () ->
(let level = 1 in
with_ledger_test_reject_and_succeed
state
EF.(wf "Setting HWM to %d" level)
(fun () ->
Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level))
>>= assert_hwms_ ~main:1 ~test:1
>>= bake
>>= assert_hwms_ ~main:4 ~test:1
>>= set_hwm_ 5
>>= assert_hwms_ ~main:5 ~test:5
>>= assert_failure state "endorsing a level beneath HWM should fail" endorse
>>= assert_failure state "baking a level beneath HWM should fail" bake
>>= set_hwm_ 4 >>= bake
>>= assert_hwms_ ~main:5 ~test:4
>>= endorse (* does not increase level since we just baked *)
>>= assert_failure state "endorsing same block twice should not work" endorse
>>= assert_hwms_ ~main:5 ~test:4
>>= bake
>>= assert_hwms_ ~main:6 ~test:4
>>= forge_endorsement state ~client:baker.client ~chain_id ~level:1
>>= fun endorsement_at_low_level_bytes ->
assert_failure
state
"endorsing-after-baking a level beneath HWM should fail"
(sign state ~client:baker ~bytes:endorsement_at_low_level_bytes)
()
>>= assert_hwms_ ~main:6 ~test:4
(* HWM has not changed *)
>>= endorse
(* HWM still has not changed *)
>>= assert_hwms_ ~main:6 ~test:4
(* Forge an endorsement on a different chain *)
>>= fun () ->
let other_chain_id = "NetXSzLHKwSumh7" in
Console.say
state
EF.(
wf "Signing a forged endorsement on a different chain: %s" other_chain_id)
>>= forge_endorsement
state
~client:baker.client
~chain_id:(Tezos_crypto.Chain_id.of_b58check_exn other_chain_id)
~level:5
>>= fun endorsement_on_different_chain_bytes ->
sign state ~client:baker ~bytes:endorsement_on_different_chain_bytes ()
(* Only the test HWM has changed *)
>>= assert_hwms_ ~main:6 ~test:5
>>= fun () ->
Loop.n_times 5 (fun _ -> bake ())
>>= ask_hwm ~main:11 ~test:5
>>= fun () ->
Tezos_client.Ledger.deauthorize_baking state ~client:(client 0) ~uri
>>= assert_failure state "baking after deauthorization should fail" bake
>>= assert_failure
state
"endorsing after deauthorization should fail"
endorse
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure
(fun uri
node_exec
client_exec
admin_exec
size
(`Base_port base_port)
no_deterministic_nonce_tests
protocol
state
->
( state,
Interactive_test.Pauser.run_test
~pp_error
state
(run
state
~protocol
~node_exec
~size
~admin_exec
~base_port
~client_exec
~enable_deterministic_nonce_tests:
(not no_deterministic_nonce_tests)
~uri) ))
$ Arg.(
required
(pos
0
(some string)
None
(info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI")))
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Tezos_executable.cli_term `Admin "tezos"
$ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network")))
$ Arg.(
pure (fun p -> `Base_port p)
$ value
(opt
int
46_000
(info ["base-port"; "P"] ~doc:"Base port number to build upon")))
$ Arg.(
value
(flag
(info
["no-deterministic-nonce-tests"]
~doc:"Disable tests for deterministic nonces")))
$ Tezos_protocol.cli_term ()
$ Test_command_line.cli_state ~name:"ledger-baking" () )
(let doc = "Interactive test exercising the Ledger Baking app features" in
info ~doc "ledger-baking")
src/bin_sandbox/command_ledger_baking.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition failf {A B : Type} (fmt : A) : B :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant) fmt.
Definition ledger_prompt_notice {A B C : Type}
(state : A) (ef : B) (op_staroptstar : option variant) : unit -> C :=
let button :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun function_parameter =>
let 'tt := function_parameter in
let button_str :=
match button with
| Checkmark => "✔" % string
| X => "❌" % string
| Both => "❌ and ✔ at the same time" % string
end in
op_startypeminuserrorstar state op_startypeminuserrorstar.
Definition assert_failure {A B C D : Type}
(state : A) (msg : B) (f : unit -> C) (function_parameter : unit) : D :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar (f tt)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
match function_parameter with
| Worked => failf "%s" % string msg
| Didn'tWork => op_startypeminuserrorstar tt
end)).
Definition failf {A B : Type} (fmt : A) : B :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant) fmt.
Definition assert_ {A : Type} (a : bool) : A :=
if a then
op_startypeminuserrorstar tt
else
failf "Assertion failed" % string.
Definition assert_eq {A B C : Type}
(to_string : A -> B) (expected : A) (actual : A) : C :=
if equiv_decb expected actual then
op_startypeminuserrorstar tt
else
failf "Assertion failed: expected %s but got %s" % string
(to_string expected) (to_string actual).
Fixpoint ask {A B C : Type} (state : A) (ef : B) : C :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| "y" % char | "Y" % char => op_startypeminuserrorstar true
| "n" % char | "N" % char => op_startypeminuserrorstar false
| _ => ask state ef
end)).
Definition ask_assert {A B C : Type}
(state : A) (ef : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar (ask state ef) (fun b => assert_ b).
Definition with_ledger_prompt {A B C D : Type}
(state : A) (message : B) (expectation : variant) (f : unit -> C) : D :=
op_startypeminuserrorstar
(ledger_prompt_notice state op_startypeminuserrorstar
(Some
match expectation with
| Succeeds =>
(* ❌ Variants not supported *)
variant
| Fails =>
(* ❌ Variants not supported *)
variant
end) tt)
(fun function_parameter =>
let 'tt := function_parameter in
match expectation with
| Succeeds =>
op_startypeminuserrorstar (f tt)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar state op_startypeminuserrorstar)
| Fails =>
op_startypeminuserrorstar
(assert_failure state "expected failure" % string f tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state op_startypeminuserrorstar)
end).
Definition with_ledger_test_reject_and_succeed {A B C D : Type}
(state : A) (ef : B) (f : unit -> C) : D :=
op_startypeminuserrorstar
(with_ledger_prompt state ef
(* ❌ Variants not supported *)
variant f)
(fun function_parameter =>
let 'tt := function_parameter in
with_ledger_prompt state ef
(* ❌ Variants not supported *)
variant f).
Definition assert_hwms {A B C D : Type}
(state : A) (client : B) (uri : C) (main : Z) (test : Z) : D :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(assert_eq OCaml.Stdlib.string_of_int main op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
assert_eq OCaml.Stdlib.string_of_int test
op_startypeminuserrorstar))).
Definition get_chain_id {A B C : Type} (state : A) (client : B) : C :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/chain_id" % string)
(fun function_parameter =>
match function_parameter with
| String x => op_startypeminuserrorstar x
| _ => failf "Failed to parse chain_id JSON from node" % string
end))
(fun chain_id_string =>
op_startypeminuserrorstar (op_startypeminuserrorstar chain_id_string)).
Definition get_head_block_hash {A B C : Type}
(state : A) (client : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/blocks/head/hash" % string)
(fun function_parameter =>
match function_parameter with
| String x => op_startypeminuserrorstar x
| _ => failf "Failed to parse block hash JSON from node" % string
end).
Definition forge_endorsement {A B C D : Type}
(state : A) (client : B) (chain_id : C) (level : Z)
(function_parameter : unit) : D :=
let 'tt := function_parameter in
op_startypeminuserrorstar (get_head_block_hash state client tt)
(fun branch =>
let json :=
(* ❌ Variants not supported *)
variant in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
"/chains/main/blocks/head/helpers/forge/operations" % string
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| String operation_bytes =>
let endorsement_magic_byte := "02" % string in
op_startypeminuserrorstar
(String.append endorsement_magic_byte
(String.append
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply chain_id
op_startypeminuserrorstar) op_startypeminuserrorstar)
operation_bytes))
| _ => failf "Failed to forge operation or parse result" % string
end)).
Definition forge_delegation {A B C : Type}
(state : A) (client : B) (src : string) (dest : string)
(op_staroptstar : option Z) : unit -> C :=
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Float constant 0.00126 is approximated by the integer 0 *)
0
end in
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (get_head_block_hash state client tt)
(fun branch =>
let json :=
(* ❌ Variants not supported *)
variant in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
"/chains/main/blocks/head/helpers/forge/operations" % string
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| String operation_bytes =>
let magic_byte := "03" % string in
op_startypeminuserrorstar
(String.append magic_byte operation_bytes)
| _ => failf "Failed to forge operation or parse result" % string
end)).
Definition sign {A B C : Type}
(state : A) (client : B) (bytes : string) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state (Tezos_client.Keyed.client client)
(cons "sign" % string
(cons "bytes" % string
(cons (String.append "0x" % string string)
(cons "for" % string (cons (Tezos_client.Keyed.key_name client) []))))))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt).
Definition originate_account_from {A B C D : Type}
(state : A) (client : B) (account : C) : D :=
let orig_account_name :=
String.append (op_startypeminuserrorstar account)
"-originated-account" % string in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "originate" % string
(cons "account" % string
(cons orig_account_name
(cons "for" % string
(cons (op_startypeminuserrorstar account)
(cons "transferring" % string
(cons (OCaml.Stdlib.string_of_int 1000)
(cons "from" % string
(cons (op_startypeminuserrorstar account)
(cons "--burn-cap" % string
(cons
(Stdlib.string_of_float
(* ❌ Float constant 0.257 is approximated by the integer 0 *)
0) []))))))))))))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar orig_account_name).
Definition setup_baking_ledger {A B C D : Type}
(state : A) (uri : string) (client : B) (protocol : C) : D :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let key_name := "ledgered" % string in
let baker := op_startypeminuserrorstar client key_name uri in
let assert_baking_key {E : Type}
(x : option string) (function_parameter : unit) : E :=
let 'tt := function_parameter in
let to_string (function_parameter : option string) : string :=
match function_parameter with
| Some x => x
| None => "<none>" % string
end in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client uri)
(fun auth_key => assert_eq to_string x auth_key)) in
op_startypeminuserrorstar
(op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
(assert_baking_key None))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
(fun account =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(with_ledger_test_reject_and_succeed state
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt)))
(assert_failure state
"baking before setup should fail" % string
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state baker
"Baked by ledger" % string)))
(assert_failure state
"endorsing before setup should fail" % string
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state baker
"Endorsed by ledger" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
let test_invalid_delegations {E : Type}
(function_parameter : unit) : E :=
let 'tt := function_parameter in
let ledger_pkh := op_startypeminuserrorstar account in
let other_pkh :=
op_startypeminuserrorstar
(fst
(op_startypeminuserrorstar
(Tezos_protocol.bootstrap_accounts protocol))) in
let cases :=
cons
(ledger_pkh, other_pkh,
"ledger to another account" % string)
(cons
(other_pkh, ledger_pkh,
"another account to ledger" % string)
(cons
(other_pkh, other_pkh,
"another account to another account" % string) []))
in
op_startypeminuserrorstar cases
(fun function_parameter =>
let '(src, dest, msg) := function_parameter in
op_startypeminuserrorstar
(forge_delegation state client src dest None tt)
(fun forged_delegation_bytes =>
assert_failure state
(op_startypeminuserrorstar
"signing a delegation from %s (%s to %s) should fail"
% string msg src dest)
(sign state baker forged_delegation_bytes) tt)) in
op_startypeminuserrorstar (test_invalid_delegations tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(with_ledger_test_reject_and_succeed state
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state client
(cons "setup" % string
(cons "ledger" % string
(cons "to" % string
(cons "bake" % string
(cons "for" % string
(cons key_name
(cons "--main-hwm" % string
(cons "0" % string
(cons "--test-hwm" % string
(cons "0" % string []))))))))))))
(assert_failure state
"signing a 'Withdraw delegate' operation in Baking App should fail"
% string
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state client
(cons "--wait" % string
(cons "none" % string
(cons "withdraw" % string
(cons "delegate" % string
(cons "from" % string
(cons
(op_startypeminuserrorstar
account) [])))))))))
(assert_baking_key (Some uri)))
test_invalid_delegations)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (baker, account))))))).
Definition run {A B C D E F G H : Type}
(state : A) (protocol : B) (node_exec : C) (client_exec : D) (admin_exec : E)
(size : F) (base_port : G) (uri : string)
(enable_deterministic_nonce_tests : bool) (function_parameter : unit) : H :=
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let ledger_client := op_startypeminuserrorstar client_exec in
op_startypeminuserrorstar
(op_startypeminuserrorstar state ledger_client uri)
(fun ledger_account =>
let protocol := op_startypeminuserrorstar in
let other_baker_account :=
fst
(op_startypeminuserrorstar
(Tezos_protocol.bootstrap_accounts protocol) 1) in
op_startypeminuserrorstar
(op_startypeminuserrorstar protocol size base_port state
node_exec client_exec)
(fun function_parameter =>
let '(nodes, protocol) := function_parameter in
let make_admin := op_startypeminuserrorstar admin_exec in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let client {I J : Type} (n : I) : J :=
op_startypeminuserrorstar client_exec
(op_startypeminuserrorstar nodes n) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state (client 0)
op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state (client 0)
op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
let assert_hwms_ {I : Type}
(main : Z) (test : Z) (function_parameter :
unit) : I :=
let 'tt := function_parameter in
assert_hwms state (client 0) uri main test in
let set_hwm_ {I J : Type}
(level : I) (function_parameter : unit) : J :=
let 'tt := function_parameter in
with_ledger_prompt state
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state (client 0)
uri level) in
op_startypeminuserrorstar
(get_chain_id state (client 0))
(fun chain_id =>
op_startypeminuserrorstar
(setup_baking_ledger state uri (client 0)
protocol)
(fun function_parameter =>
let '(baker, ledger_account) :=
function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
let bake {I : Type}
(function_parameter : unit) : I :=
let 'tt := function_parameter in
op_startypeminuserrorstar state baker
"Baked by ledger" % string in
let endorse {I : Type}
(function_parameter : unit) : I :=
let 'tt := function_parameter in
op_startypeminuserrorstar state baker
"Endorsed by ledger" % string in
let ask_hwm {I : Type}
(main : Z) (test : Z)
(function_parameter : unit) : I :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_hwms_ main test tt)
(ask_assert state
op_startypeminuserrorstar) in
op_startypeminuserrorstar
(if enable_deterministic_nonce_tests
then
op_startypeminuserrorstar
(op_startypeminuserrorstar state
baker "this" % string)
(fun thisNonce1 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
baker "that" % string)
(fun thatNonce1 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker
"this" % string)
(fun thisNonce2 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker
"that" % string)
(fun thatNonce2 =>
op_startypeminuserrorstar
(assert_eq
(fun x => x)
thisNonce1
thisNonce2)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_eq
(fun x => x)
thatNonce1
thatNonce2)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
assert_
(nequiv_decb
thisNonce1
thatNonce1)))))))
else
op_startypeminuserrorstar tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_failure state
"originating an account from the Tezos Baking app should fail"
% string
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(originate_account_from state
(client 0) ledger_account)
(fun function_parameter =>
let '_ := function_parameter
in
op_startypeminuserrorstar tt))
tt)
(fun function_parameter =>
let 'tt := function_parameter in
let fee :=
(* ❌ Float constant 0.00126 is approximated by the integer 0 *)
0 in
let ledger_pkh :=
op_startypeminuserrorstar
ledger_account in
op_startypeminuserrorstar
(forge_delegation state
(client 0) ledger_pkh
ledger_pkh (Some fee) tt)
(fun forged_delegation_bytes =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(with_ledger_test_reject_and_succeed
state
op_startypeminuserrorstar
(sign state baker
forged_delegation_bytes))
bake) (ask_hwm 3 0))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(let
level :=
1
in
with_ledger_test_reject_and_succeed
state
op_startypeminuserrorstar
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
(client
0)
uri
level))
(assert_hwms_
1
1))
bake)
(assert_hwms_
4
1))
(set_hwm_
5))
(assert_hwms_
5
5))
(assert_failure
state
"endorsing a level beneath HWM should fail"
%
string
endorse))
(assert_failure
state
"baking a level beneath HWM should fail"
%
string
bake))
(set_hwm_
4))
bake)
(assert_hwms_
5 4))
endorse)
(assert_failure
state
"endorsing same block twice should not work"
% string
endorse))
(assert_hwms_ 5
4)) bake)
(assert_hwms_ 6 4))
(forge_endorsement
state (client baker)
chain_id 1))
(fun
endorsement_at_low_level_bytes
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(assert_failure
state
"endorsing-after-baking a level beneath HWM should fail"
% string
(sign state
baker
endorsement_at_low_level_bytes)
tt)
(assert_hwms_
6 4))
endorse)
(assert_hwms_ 6 4))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
let
other_chain_id :=
"NetXSzLHKwSumh7"
% string in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(forge_endorsement
state
(client
baker)
(op_startypeminuserrorstar
other_chain_id)
5))
(fun
endorsement_on_different_chain_bytes
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(sign
state
baker
endorsement_on_different_chain_bytes
tt)
(assert_hwms_
6 5))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
5
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
bake
tt))
(ask_hwm
11 5))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
0)
uri)
(assert_failure
state
"baking after deauthorization should fail"
%
string
bake))
(assert_failure
state
"endorsing after deauthorization should fail"
%
string
endorse))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_ledger_wallet.ml 527 errors
open Flextesa
open Internal_pervasives
let client_async_cmd state ~client args ~f =
Running_processes.Async.run_cmdf
~id_base:"client_async_cmd"
state
~f
"sh -c %s"
( Tezos_client.client_command client ~state args
|> Genspio.Compile.to_one_liner |> Filename.quote )
>>= fun (status, res) ->
return
( object
method out = fst res
method err = snd res
method status = status
end
: Process_result.t )
let ledger_hash_re =
lazy
Re.(
compile
(seq
[ str "* Blake 2B Hash (ledger-style, with operation watermark):";
rep1 (alt [space; eol]);
group (rep1 alnum);
rep1 (alt [space; eol]) ]))
(* Searches a stream for an expected ledger hash from `tezos-client --verbose-signing`*)
let find_and_print_signature_hash ?(display_expectation = true) state process =
let re = Lazy.force ledger_hash_re in
let check lines =
Re.(
match exec_opt re lines with
| None ->
None
| Some matches ->
Some (Group.get matches 1))
in
(* Dbg.e EF.(wf "find_and_print_signature_hash") ; *)
Running_processes.Async.fold_process
process
~init:("", "", not display_expectation)
~f:(fun (all_output_prev, all_error_prev, showed_message_prev) out err ->
(* Dbg.e EF.(wf "find_and_print_signature_hash.fold_process %S %S" out err) ; *)
let all_output = all_output_prev ^ out in
let all_error = all_error_prev ^ err in
( if not showed_message_prev then
match check all_output with
| None ->
return false
| Some x ->
Console.say state EF.(wf "Displayed hash should be: `%s`" x)
>>= fun () -> return true
else return true )
>>= fun showed_message ->
return (`Continue (all_output, all_error, showed_message)))
>>= fun (output, error, _) ->
return (String.split ~on:'\n' output, String.split ~on:'\n' error)
module MFmt = Experiments.More_fmt
let failf ?attach fmt =
ksprintf (fun s -> fail ?attach (`Scenario_error s)) fmt
let process_should_fail msg f =
Asynchronous_result.bind_on_error
( f ()
>>= fun (proc : Process_result.t) ->
match proc#status with
| Unix.WEXITED 0 ->
failf
"Process should have failed: %s"
msg
~attach:
[("stdout", `Verbatim proc#out); ("stderr", `Verbatim proc#err)]
| _ ->
return () )
~f:(fun ~result:_ _ -> return ())
let ledger_prompt_notice state ~msgs ?(button = `Checkmark) () =
let button_str =
match button with
| `Checkmark ->
"â"
| `X ->
"â"
| `Both ->
"â and â at the same time"
in
Console.sayf
state
MFmt.(
fun ppf () ->
vertical_box ~indent:4 ppf (fun ppf ->
shout ppf (fun ppf -> const string "Ledger-prompt:" ppf ()) ;
cut ppf () ;
List.iter msgs ~f:(fun f -> f ppf () ; cut ppf ()) ;
wf ppf "â Press %s on the ledger." button_str))
let ledger_prompt_notice_expectation state ~messages ~user_answer =
ledger_prompt_notice
state
()
~button:(match user_answer with `Accept -> `Checkmark | `Reject -> `X)
~msgs:
( messages
@ MFmt.
[ cut;
(fun ppf () ->
match user_answer with
| `Accept ->
shout ppf (fun ppf -> pf ppf ">> ACCEPT THIS <<")
| `Reject ->
shout ppf (fun ppf -> pf ppf ">> REJECT THIS <<")) ] )
let with_ledger_test_reject_and_accept ?(only_success = false) state ~messages
f =
let with_ledger_prompt state ~messages ~user_answer ~f =
ledger_prompt_notice_expectation state ~messages ~user_answer
>>= fun () -> f ~user_answer
in
( if only_success then return ()
else with_ledger_prompt state ~messages ~user_answer:`Reject ~f )
>>= fun () -> with_ledger_prompt state ~messages ~user_answer:`Accept ~f
let get_chain_id state ~client =
Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id"
>>= (function
| `String x ->
return x
| _ ->
failf "Failed to parse chain_id JSON from node")
>>= fun chain_id_string ->
return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string)
let get_head_block_hash state ~client () =
Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash"
>>= function
| `String x ->
return x
| _ ->
failf "Failed to parse block hash JSON from node"
let please_check_the_hash ppf () =
let open MFmt in
tag "prompt" ppf (fun ppf ->
wf ppf "The ledger cannot parse this operation, please verify the hash.")
let forge_batch_transactions state ~client ~src ~dest:_ ~n ?(fee = 0.00126) ()
=
get_head_block_hash state ~client ()
>>= fun branch ->
let json =
`O
[ ("branch", `String branch);
( "contents",
`A
(List.map (List.range 0 n) ~f:(fun i ->
`O
[ ("kind", `String "transaction");
("source", `String src);
( "destination",
`String "tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F" );
("amount", `String (string_of_int 100));
( "fee",
`String (string_of_int (int_of_float (fee *. 1000000.)))
);
("counter", `String (string_of_int i));
("gas_limit", `String (string_of_int 127));
("storage_limit", `String (string_of_int 277)) ])) ) ]
in
Tezos_client.rpc
state
~client
~path:"/chains/main/blocks/head/helpers/forge/operations"
(`Post (Ezjsonm.to_string json))
>>= function
| `String operation_bytes ->
let magic_byte = "03" in
return (magic_byte ^ operation_bytes)
| _ ->
failf "Failed to forge operation or parse result"
let expect_from_output ~expectation ~message (proc_res : Process_result.t) =
(* let expect_rejection msg (success, (stdout, stderr)) = *)
let exp =
match expectation with
| `Ledger_reject_or_timeout ->
"rejection"
| `Not_a_delegate ->
"not-delegate-error"
| `Success ->
"success"
| `Origination_failed ->
"origination-failure"
in
let nope s =
failf
~attach:
[("stdout", `Verbatim proc_res#out); ("stderr", `Verbatim proc_res#err)]
"%s, expected %s: %s."
message
exp
s
in
let success = proc_res#status = Unix.WEXITED 0 in
match expectation with
| `Success when success ->
return ()
| `Success ->
nope "did not succeed"
| (`Ledger_reject_or_timeout | `Not_a_delegate | `Origination_failed) as e
-> (
let pattern =
match e with
| `Ledger_reject_or_timeout ->
"Conditions of use not satisfied"
| `Not_a_delegate ->
"not registered as valid delegate key"
| `Origination_failed ->
"origination simulation failed"
in
let all_output = String.concat ~sep:"\n" (proc_res#out @ proc_res#err) in
match (success, String.substr_index all_output ~pattern) with
| (false, Some _) ->
return ()
| (false, None) ->
nope "cannot find the right error message"
| (true, _) ->
nope "command succeeded??" )
let voting_tests state ~client ~src ~with_rejections ~protocol_kind
~ledger_account ~tested_proposal ~go_to_next_period () =
let expect_success message v =
expect_from_output ~expectation:`Not_a_delegate ~message v
in
let expect_rejection message v =
expect_from_output ~expectation:`Ledger_reject_or_timeout ~message v
in
let test_reject_and_accept name ~messages action =
( if with_rejections then
ledger_prompt_notice_expectation state ~messages ~user_answer:`Reject
>>= fun () -> action () >>= fun res -> expect_rejection name res
else return () )
>>= fun () ->
ledger_prompt_notice_expectation state ~messages ~user_answer:`Accept
>>= fun () -> action () >>= fun res -> expect_success name res
in
let source_display = Tezos_protocol.Account.pubkey_hash ledger_account in
let submit_proposals ~display_expectation proposals () =
client_async_cmd
state
~client:(client 0)
~f:(fun _ proc ->
find_and_print_signature_hash ~display_expectation state proc)
( ["submit"; "proposals"; "for"; src]
@ proposals
@ ["--force"; "--verbose-signing"] )
in
test_reject_and_accept
"single-proposal"
~messages:
MFmt.
[ (fun ppf () -> wf ppf "Submitting single proposal %s" tested_proposal);
(fun ppf () ->
match protocol_kind with
| `Athens ->
()
| `Babylon ->
wf
ppf
"On Babylon, You will first be asked to provide the public \
key." ;
cut ppf () ;
wf
ppf
"Accept this prompt, regardless of below, then continue.");
(fun ppf () ->
vertical_box ppf ~indent:4 (fun ppf ->
wf
ppf
"Protocol is %a, the ledger should be able to display \
voting parameters:"
Tezos_protocol.Protocol_kind.pp
protocol_kind ;
cut ppf () ;
wf ppf "* Source: `%s`" source_display ;
cut ppf () ;
wf ppf "* Period: `0`" ;
cut ppf () ;
wf ppf "* Protocol: `%s`" tested_proposal)) ]
(submit_proposals ~display_expectation:false [tested_proposal])
>>= fun () ->
test_reject_and_accept
"multiple-proposal"
~messages:
MFmt.
[ (fun ppf () -> wf ppf "Submitting 2 proposals together");
please_check_the_hash ]
(submit_proposals
~display_expectation:true
[tested_proposal; "Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z"])
>>= fun () ->
go_to_next_period ()
>>= fun () ->
List_sequential.iteri ["yea"; "nay"] ~f:(fun n vote ->
test_reject_and_accept
(Fmt.strf "vote-%s" vote)
~messages:
MFmt.
[ (fun ppf () ->
match protocol_kind with
| `Athens ->
()
| `Babylon ->
wf
ppf
"On Babylon, You will first be asked to provide the \
public key." ;
cut ppf () ;
wf
ppf
"Accept this prompt, regardless of below, then continue.");
(fun ppf () -> wf ppf "Voting %s for %s" vote tested_proposal);
(fun ppf () -> wf ppf "Source: `%s`" source_display);
(fun ppf () -> wf ppf "Period: `%i`" (n + 1));
(fun ppf () -> wf ppf "Protocol: `%s`" tested_proposal) ]
(fun () ->
Tezos_client.client_cmd
state
~client:(client 0)
["submit"; "ballot"; "for"; src; tested_proposal; vote]
>>= fun (_, proc) -> return proc))
let ledger_should_display ppf l =
let open MFmt in
vertical_box ~indent:4 ppf (fun ppf ->
wf ppf "Ledger should display:" ;
List.iter l ~f:(fun (s, f) -> cut ppf () ; pf ppf "* %s: %a." s f ()))
let show_command_message command =
MFmt.(
fun ppf () ->
wrapping_box ~indent:2 ppf (fun ppf ->
wf ppf "Command:" ;
sp ppf () ;
const
(list ~sep:sp string)
("<tezos-client>" :: command |> List.map ~f:Filename.quote)
ppf
()))
let sign state ~client ~bytes =
Tezos_client.client_cmd
state
~client:client.Tezos_client.Keyed.client
["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name]
let delegation_tests state ~client ~src ~with_rejections ~protocol_kind
~ledger_account ~delegate ~bake () =
let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
let only_success = not with_rejections in
let self_delegation () =
(* Which is equivalent to registration as delegate. *)
let command =
[ "--wait";
"none";
"set";
"delegate";
"for";
src;
"to";
src;
"--verbose-signing" ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () -> wf ppf "Self-delegating account `%s`" ledger_pkh);
show_command_message command;
(fun ppf () ->
wf
ppf
"Note that X is a placeholder for some value that will vary \
between runs");
(fun ppf () ->
ledger_should_display
ppf
[ ("Fee", const string "0.00XXX");
("Source", const string ledger_pkh);
("Delegate", const string ledger_pkh);
("Storage", const int 0) ]) ]
(fun ~user_answer ->
client_async_cmd
state
~client
~f:(fun _ proc ->
find_and_print_signature_hash
~display_expectation:(protocol_kind = `Babylon)
state
proc)
command
>>= fun res ->
expect_from_output
~message:"self-delegation"
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success ))
>>= fun _ -> ksprintf bake "setting self-delegate of %s" src
(* Self-delegate deletion is forbidden for both Athens and Babylon *)
in
let tz_account_delegation () =
let command =
[ "--wait";
"none";
"set";
"delegate";
"for";
src;
"to";
delegate;
"--verbose-signing" ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Delegating account `%s` to `%s`" ledger_pkh delegate);
show_command_message command;
(fun ppf () ->
wf
ppf
"Note that X is a placeholder for some value that will vary \
between runs");
(fun ppf () ->
ledger_should_display
ppf
[ ("Fee", const string "0.00XXX");
("Source", const string ledger_pkh);
("Delegate", const string delegate);
("Storage", const int 0) ]) ]
(fun ~user_answer ->
client_async_cmd
state
~client
~f:(fun _ proc ->
find_and_print_signature_hash
~display_expectation:(protocol_kind = `Babylon)
state
proc)
command
>>= fun res ->
expect_from_output
~message:"tz123-delegation"
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success ))
>>= fun _ -> ksprintf bake "setting delegate of %s" src
(* Self-delegate deletion is forbidden for both Athens and Babylon *)
in
let run_command_and_check state ~client ~command ~message ~user_answer =
Tezos_client.client_cmd state ~client command
>>= fun (_, res) ->
expect_from_output
~message
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success )
in
let delegate_with_scriptless_account () =
let originated_account_name = "ledginated" in
let amount = "200" in
let burn_cap = "0.257" in
let command =
[ "--wait";
"none";
"originate";
"account";
originated_account_name;
"for";
src;
"transferring";
"200";
"from";
src;
"--delegatable";
"--burn-cap";
burn_cap;
"--force" ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Originating account `%s`" originated_account_name);
(fun ppf () ->
ledger_should_display
ppf
[ ("Amount", const string amount);
("Fee", const string (strf "⤠%S" burn_cap));
("Source", const string ledger_pkh);
("Manager", const string ledger_pkh);
("Delegation", const string "Any");
("Storage", const int 277) ]) ]
(fun ~user_answer ->
run_command_and_check
state
~client
~command
~message:"account origination"
~user_answer)
>>= fun _ ->
ksprintf bake "origination of %s" originated_account_name
>>= fun () ->
Tezos_client.client_cmd
state
~client
["show"; "known"; "contract"; originated_account_name]
>>= fun (_, proc_result) ->
let contract_address = proc_result#out |> String.concat ~sep:"" in
Tezos_client.client_cmd state ~client ["show"; "address"; delegate]
>>= fun (_, proc_result) ->
let delegate_address =
List.hd_exn proc_result#out
|> String.split ~on:' ' |> List.last
|> Option.value ~default:delegate
in
let command =
[ "--wait";
"none";
"set";
"delegate";
"for";
originated_account_name;
"to";
delegate ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf
ppf
"Setting `%s` as delegate for `%s`"
delegate
originated_account_name);
(fun ppf () ->
ledger_should_display
ppf
[ ("Source", const string contract_address);
("Fee", const string "⤠0.001");
("Delegate", const string delegate_address);
("Storage", const int 0) ]) ]
(fun ~user_answer ->
run_command_and_check
state
~client
~command
~message:"setting delegate of KT1"
~user_answer)
>>= fun () ->
ksprintf bake "setting delegate of %s" originated_account_name
>>= fun () ->
let withdraw_command =
[ "--wait";
"none";
"withdraw";
"delegate";
"from";
originated_account_name ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Withdrawing delegate from `%s`" originated_account_name);
show_command_message withdraw_command;
(fun ppf () ->
ledger_should_display
ppf
[ ("Source", const string contract_address);
("Fee", const string "⤠0.001");
("Delegate", const string "None");
("Storage", const int 0) ]) ]
(fun ~user_answer ->
run_command_and_check
state
~client
~command:withdraw_command
~message:"withdrawing delegate from originated account"
~user_answer)
>>= fun () ->
ksprintf bake "withdrawing delegate of %s" originated_account_name
in
match protocol_kind with
| `Athens ->
self_delegation () >>= fun () -> delegate_with_scriptless_account ()
| `Babylon ->
tz_account_delegation () >>= fun () -> self_delegation ()
let transaction_tests state ~client ~src ~with_rejections ~protocol_kind
~pair_string_nat_kt1_account ~ledger_account ~unit_kt1_account ~bake () =
let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
let only_success = not with_rejections in
let test_transaction ?(storage = 0) ?arguments ~name ~dst_name ~dst_pkh () =
let amount = "15" in
let command =
["--wait"; "none"; "transfer"; amount; "from"; src; "to"; dst_name]
@ Option.value_map ~default:[] arguments ~f:(fun a -> ["--arg"; a])
@ ["--burn-cap"; "100"; "--verbose-signing"]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () -> wf ppf "%s with account `%s`" name ledger_pkh);
show_command_message command;
(fun ppf () ->
wf
ppf
"Note that X is a placeholder for some value that will vary \
between runs");
(fun ppf () ->
match arguments with
| None ->
ledger_should_display
ppf
[ ("Amount", const string amount);
("Fee", const string "0.00XXX");
("Source", const string ledger_pkh);
("Destination", const string dst_pkh);
("Storage", const int storage) ]
| _ (* some arguments *) ->
please_check_the_hash ppf ()) ]
(fun ~user_answer ->
client_async_cmd
state
~client
~f:(fun _ proc ->
find_and_print_signature_hash
~display_expectation:
(protocol_kind = `Babylon || arguments <> None)
state
proc)
command
>>= fun res ->
expect_from_output
~message:name
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success ))
>>= fun _ -> ksprintf bake "%s with %s" name src
in
test_transaction
~name:"Self-transaction"
~dst_pkh:ledger_pkh
~dst_name:src
()
>>= fun () ->
let module Acc = Tezos_protocol.Account in
let random_account = Acc.of_name "random-account-for-transaction-test" in
test_transaction
~name:"transaction-to-random-tz1"
~dst_pkh:(Acc.pubkey_hash random_account)
~dst_name:(Acc.pubkey_hash random_account)
~storage:277
(* First time: there is a reveal *) ()
>>= fun () ->
test_transaction
~name:"transaction-to-random-tz1-again"
~dst_pkh:(Acc.pubkey_hash random_account)
~dst_name:(Acc.pubkey_hash random_account)
~storage:0
(* no moa reveal *) ()
>>= fun () ->
test_transaction
~name:"parameterless-transaction-to-kt1"
~dst_pkh:"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
~dst_name:unit_kt1_account
()
>>= fun () ->
test_transaction
~name:"parameterfull-transaction-to-kt1"
~dst_pkh:"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
~arguments:"Pair \"hello from the ledger\" 51"
~dst_name:pair_string_nat_kt1_account
()
let prepare_origination_of_id_script ?(spendable = false)
?(delegatable = false) ?delegate ?(push_drops = 0) ?(amount = "2") state
~client:_ ~name ~from ~protocol_kind ~parameter ~init_storage =
let id_script parameter =
Fmt.strf
"parameter %s;\n\
storage %s;\n\
code\n\
\ {\n\
\ %s\n\
\ { CAR; NIL operation; PAIR }\n\
\ };\n"
parameter
parameter
( match push_drops with
| 0 ->
"# No push-drops"
| n ->
Fmt.strf
"# %d push-drop%s\n %s"
n
(if n > 1 then "s" else "")
( List.init push_drops ~f:(fun ith ->
Fmt.strf
"{ PUSH string %S ; DROP } ;"
(Fmt.strf
"push-dropping %d adds stupid bytes to the contract"
ith))
|> String.concat ~sep:"\n " ) )
in
let tmp = Filename.temp_file "little-id-script" ".tz" in
System.write_file state tmp ~content:(id_script parameter)
>>= fun () ->
Dbg.e EF.(wf "id_script %s: %s" parameter tmp) ;
let origination =
let opt = Option.value_map ~default:[] in
["--wait"; "none"; "originate"; "contract"; name]
@ (match protocol_kind with `Athens -> ["for"; from] | `Babylon -> [])
@ [ "transferring";
amount;
"from";
from;
"running";
tmp;
"--init";
init_storage;
"--force";
"--burn-cap";
"300000000000";
(* ; "--fee-cap" ; "20000000000000" *)
"--gas-limit";
"1000000000000000";
"--storage-limit";
"20000000000000";
"--verbose-signing" ]
@ opt delegate ~f:(fun s -> (* Baby & Aths *) ["--delegate"; s])
@ (if delegatable then [(* Aths *) "--delegatable"] else [])
@ if spendable then [(* Aths *) "--spendable"] else []
in
return origination
let originate_id_script ?push_drops state ~client ~name ~from ~bake
~protocol_kind ~parameter ~init_storage =
prepare_origination_of_id_script
state
~client
~name
~from
~protocol_kind
?push_drops
~parameter
~init_storage
>>= fun origination ->
Tezos_client.successful_client_cmd state ~client origination
>>= fun _ -> Fmt.kstrf bake "baking `%s` in" name
let pp_warning_ledger_takes_a_while ~adjective =
let open MFmt in
fun ppf () ->
cut ppf () ;
let prompt = "WARNING: " in
let warning1 = "The ledger will take a few seconds to show" in
let warning2 = strf "the hash for such a %s operation." adjective in
let wl = String.length prompt + String.length warning1 in
tag "shout" ppf (fun ppf -> string ppf ("/" ^ String.make wl '=' ^ "\\")) ;
cut ppf () ;
tag "shout" ppf (fun ppf -> pf ppf "|%s" prompt) ;
string ppf warning1 ;
tag "shout" ppf (fun ppf -> string ppf "|") ;
cut ppf () ;
tag "shout" ppf (fun ppf -> pf ppf "|") ;
string ppf String.(make (length prompt) ' ') ;
string ppf warning2 ;
string ppf String.(make (length warning1 - length warning2) ' ') ;
tag "shout" ppf (fun ppf -> string ppf "|") ;
cut ppf () ;
tag "shout" ppf (fun ppf -> string ppf ("\\" ^ String.make wl '=' ^ "/"))
let basic_contract_operations_tests state ~client ~src ~with_rejections
~protocol_kind ~ledger_account ~bake ~delegate () =
let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
let only_success = not with_rejections in
let test_origination ?delegate ?delegatable ?spendable ?push_drops ~name
~amount ~parameter ~init_storage () =
prepare_origination_of_id_script
~amount
?push_drops
state
~client
~name
~from:src
?delegate
?delegatable
?spendable
~protocol_kind
~parameter
~init_storage
>>= fun origination ->
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Origination: %s (ledger: %s)" name ledger_pkh);
show_command_message origination;
please_check_the_hash;
( if push_drops <> None then
pp_warning_ledger_takes_a_while ~adjective:"huge"
else const string "" ) ]
(fun ~user_answer ->
client_async_cmd
state
~client
~f:(fun _ proc ->
find_and_print_signature_hash ~display_expectation:true state proc)
origination
>>= fun res ->
expect_from_output
~message:name
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success ))
>>= fun _ -> ksprintf bake "%s with %s" name src
in
test_origination
~name:"ID-unit"
~amount:"0"
~parameter:"unit"
~init_storage:"Unit"
()
>>= fun () ->
test_origination
~name:"ID-string"
~amount:"10"
~parameter:"string"
~init_storage:"\"some string\""
()
>>= fun () ->
test_origination
~name:"ID-string-nat-mutez"
~amount:"10"
~parameter:"(pair string (pair nat mutez))"
~init_storage:"Pair \"hello\" (Pair 12 1)"
()
>>= fun () ->
test_origination
~name:"ID-address+delegate"
~amount:"1"
~parameter:"address"
~delegate
~init_storage:"\"tz1YPSCGWXwBdTncK2aCctSZAXWvGsGwVJqU\""
()
>>= fun () ->
( match protocol_kind with
| `Athens ->
test_origination
~name:"ID-string+delegatable"
~amount:"0"
~parameter:"string"
~delegate
~init_storage:"\"delegatable contract\""
~delegatable:true
()
| `Babylon ->
return () )
>>= fun () ->
let push_drops =
(* Found by dichotomic trial-and-error :)
240 works, 250 fails at 16870 bytes, ⦠*)
242
in
test_origination
~push_drops
~name:"giant-contract"
~amount:"10"
~parameter:"(pair string nat)"
~init_storage:"Pair \"the answer is: \" 42"
()
module Wallet_scenario = struct
type root =
[ `All
| `Voting
| `Batch_transactions
| `Delegation
| `Transactions
| `Contracts
| `None ]
type t = [root | `Without_rejections of root]
let with_rejections : t -> bool = function
| `Without_rejections _ ->
false
| _ ->
true
let enum_assoc : (string * root) list =
[ ("everything", `All);
("voting", `Voting);
("none", `None);
("delegation", `Delegation);
("transactions", `Transactions);
("contracts", `Contracts);
("batch-transactions", `Batch_transactions) ]
let root (ws : t) =
match ws with `Without_rejections r -> r | #root as r -> r
let run_if v t ~yes ~no =
let with_rejections = with_rejections t in
match root t with
| `All ->
yes ~with_rejections
| other when other = v ->
yes ~with_rejections
| _other ->
no
(List.find_map_exn enum_assoc ~f:(function
| (k, this) when v = this ->
Some k
| _ ->
None))
let if_voting t = run_if `Voting t
let if_batch_transactions t = run_if `Batch_transactions t
let if_delegation t = run_if `Delegation t
let if_transactions t = run_if `Transactions t
let if_contracts t = run_if `Contracts t
let cli_term () =
let make no_rejections v =
if no_rejections then `Without_rejections v else (v :> t)
in
let open Cmdliner in
let open Term in
pure make
$ Arg.(
value
(flag (info ["no-rejections"] ~doc:"Do not test ledger rejections.")))
$ Arg.(
value
(opt
(enum ([("all", `All)] @ enum_assoc))
`All
(info
["only-test"]
~doc:
(Fmt.strf
"Limit to a family of tests (one of: %s)."
( List.map enum_assoc ~f:(fun (n, _) -> sprintf "`%s`" n)
|> String.concat ~sep:", " )))))
end
let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec
~admin_exec ~wallet_scenario ~size ~base_port ~uri () =
Helpers.clear_root state
>>= fun () ->
Helpers.System_dependencies.precheck
state
`Or_fail
~executables:[node_exec; client_exec; admin_exec]
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[af "Ready to start"; af "Root path deleted."]
>>= fun () ->
let ledger_client = Tezos_client.no_node_client ~exec:client_exec in
Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri
>>= fun _ledger_account ->
let (protocol, baker_0_account, _baker_0_balance) =
let open Tezos_protocol in
let d = protocol in
let baker = List.nth_exn d.bootstrap_accounts 0 in
( {
d with
kind = protocol_kind;
time_between_blocks = [1; 0];
bootstrap_accounts =
List.map d.bootstrap_accounts ~f:(fun (n, v) ->
if fst baker = n then (n, v) else (n, 1_000L));
},
fst baker,
snd baker )
in
Test_scenario.network_with_protocol
~protocol
~size
~base_port
state
~node_exec
~client_exec
>>= fun (nodes, protocol) ->
let client n =
Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
in
let client_0 = client 0 in
let baker_0 =
Tezos_client.Keyed.make
client_0
~key_name:"baker-0"
~secret_key:(Tezos_protocol.Account.private_key baker_0_account)
in
Tezos_client.Keyed.initialize state baker_0
>>= fun _ ->
let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
@ arbitrary_commands_for_each_and_all_clients
state
~make_admin
~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
let first_bakes = 3 in
Loop.n_times first_bakes (fun nth ->
ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth)
>>= fun () ->
Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
>>= fun () ->
let signer =
Tezos_client.Keyed.make (client 0) ~key_name:"ledgered" ~secret_key:uri
in
Tezos_client.Ledger.show_ledger state ~client:client_0 ~uri
>>= fun ledger_account ->
Tezos_client.successful_client_cmd
state
~client:client_0
[ "--wait";
"none";
"transfer";
"20000";
"from";
baker_0.Tezos_client.Keyed.key_name;
"to" (* *);
Tezos_protocol.Account.pubkey_hash ledger_account;
"--burn-cap";
"100" ]
>>= fun _ ->
let bake msg = Tezos_client.Keyed.bake state baker_0 msg in
bake "After transferring tez to the ledger account"
>>= fun () ->
with_ledger_test_reject_and_accept
~only_success:(Wallet_scenario.with_rejections wallet_scenario |> not)
state
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Importing %S in client `%s`." uri client_0.Tezos_client.id);
(fun ppf () ->
wf
ppf
"The ledger should be prompting for acknowledgment to provide \
the public key of `%s`."
(Tezos_protocol.Account.pubkey_hash ledger_account)) ]
(fun ~user_answer ->
Tezos_client.client_cmd
state
~client:client_0
[ "import";
"secret";
"key";
signer.key_name;
signer.secret_key;
"--force" ]
>>= fun (_, proc) ->
expect_from_output
~message:"importing key"
proc
~expectation:
( match user_answer with
| `Accept ->
`Success
| `Reject ->
`Ledger_reject_or_timeout ))
>>= fun () ->
let skipping s = Console.say state EF.(haf "Skipping %s tests" s) in
let voting_test ~with_rejections =
let tested_proposal =
"Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd"
in
voting_tests
state
~client
~ledger_account
~src:signer.key_name
()
~with_rejections
~protocol_kind
~tested_proposal
~go_to_next_period:(fun () ->
Tezos_client.successful_client_cmd
state
~client:client_0
[ "--wait";
"none";
"submit";
"proposals";
"for";
baker_0.Tezos_client.Keyed.key_name;
tested_proposal;
"--force" ]
>>= fun _ ->
let blocks = protocol.Tezos_protocol.blocks_per_voting_period in
Loop.n_times blocks (fun nth ->
ksprintf
(Tezos_client.Keyed.bake state baker_0)
"going to testing-vote period %d/%d"
(nth + 1)
blocks)
>>= fun () -> return ())
in
let batch_test ~with_rejections =
let n = 50 in
forge_batch_transactions
state
~client:(client 0)
~src:(Tezos_protocol.Account.pubkey_hash ledger_account)
~dest:"tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F"
~n
()
>>= fun batch_transaction_bytes ->
let bytes_hash =
Tezos_crypto.(
`Hex batch_transaction_bytes |> Hex.to_bytes
|> (fun x -> [x])
|> Blake2B.hash_bytes |> Blake2B.to_string |> Base58.raw_encode)
in
with_ledger_test_reject_and_accept
state
~only_success:(not with_rejections)
~messages:
MFmt.
[ (fun ppf () -> wf ppf "Signing batch of %d transactions" n);
(fun ppf () ->
wf
ppf
"Ledger should display âSign Hashâ â `%s`"
bytes_hash);
pp_warning_ledger_takes_a_while ~adjective:"big" ]
(fun ~user_answer ->
sign state ~client:signer ~bytes:batch_transaction_bytes
>>= fun (_, proc) ->
expect_from_output
~message:"Signing batch operation"
proc
~expectation:
( match user_answer with
| `Accept ->
`Success
| `Reject ->
`Ledger_reject_or_timeout ))
in
let delegation_tests ~with_rejections =
delegation_tests
state
~client:client_0
~ledger_account
~delegate:baker_0.Tezos_client.Keyed.key_name
~src:signer.key_name
()
~bake
~with_rejections
~protocol_kind
in
let unit_kt1_account = "unit-kt1-of-the-baker" in
originate_id_script
state
~client:client_0
~name:unit_kt1_account
~from:baker_0.Tezos_client.Keyed.key_name
~bake
~protocol_kind
~parameter:"unit"
~init_storage:"Unit"
>>= fun () ->
let pair_string_nat_kt1_account = "pair-string-nat-kt1-of-the-baker" in
originate_id_script
state
~client:client_0
~name:pair_string_nat_kt1_account
~push_drops:10
~from:baker_0.Tezos_client.Keyed.key_name
~bake
~protocol_kind
~parameter:"(pair string nat)"
~init_storage:"Pair \"the answer is: \" 42"
>>= fun () ->
let transactions_test ~with_rejections =
transaction_tests
state
~client:client_0
~ledger_account
~unit_kt1_account
~pair_string_nat_kt1_account
~src:signer.key_name
()
~bake
~with_rejections
~protocol_kind
in
let contracts_test ~with_rejections =
basic_contract_operations_tests
state
~client:client_0
~ledger_account
~delegate:baker_0.Tezos_client.Keyed.key_name
~src:signer.key_name
()
~bake
~with_rejections
~protocol_kind
in
let bake_command =
Console.Prompt.unit_and_loop
EF.(wf "Bake a block with the default baker.")
["bake"]
(fun _sexps ->
Asynchronous_result.transform_error
~f:(fun e ->
Format.kasprintf
(fun s -> `Command_line s)
"run-test-error: %a"
pp_error
e)
(bake "Interactive"))
in
let run_test_command =
Console.Prompt.unit_and_loop
EF.(
wf
"Run a test (%s)."
(List.map Wallet_scenario.enum_assoc ~f:fst |> String.concat ~sep:"|"))
["rt"; "run-test"]
(fun sexps ->
Asynchronous_result.transform_error
~f:(fun e ->
Format.kasprintf
(fun s -> `Command_line s)
"run-test-error: %a"
pp_error
e)
( match sexps with
| [Atom a] -> (
let run f = f ~with_rejections:true in
match
List.Assoc.find
~equal:String.equal
Wallet_scenario.enum_assoc
a
with
| Some `None ->
return ()
| Some `Delegation ->
run delegation_tests
| Some `All ->
run delegation_tests
>>= fun () -> run batch_test >>= fun () -> run voting_test
| Some `Batch_transactions ->
run batch_test
| Some `Transactions ->
run transactions_test
| Some `Voting ->
run voting_test
| Some `Contracts ->
run contracts_test
| None ->
failf "Don't know this test: %S" a )
| _ ->
failf "Cannot understand command line" ))
in
Interactive_test.Pauser.add_commands state [run_test_command; bake_command] ;
Wallet_scenario.if_voting wallet_scenario ~yes:voting_test ~no:skipping
>>= fun () ->
Wallet_scenario.if_batch_transactions
wallet_scenario
~yes:batch_test
~no:skipping
>>= fun () ->
Wallet_scenario.if_transactions
wallet_scenario
~yes:transactions_test
~no:skipping
>>= fun () ->
Wallet_scenario.if_contracts wallet_scenario ~yes:contracts_test ~no:skipping
>>= fun () ->
Wallet_scenario.if_delegation
wallet_scenario
~yes:delegation_tests
~no:skipping
>>= fun () -> Interactive_test.Pauser.generic state EF.[af "Tests done."]
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure
(fun uri
node_exec
client_exec
admin_exec
size
(`Base_port base_port)
protocol
wallet_scenario
state
->
( state,
Interactive_test.Pauser.run_test
~pp_error
state
(run
state
~protocol_kind:protocol.kind
~node_exec
~size
~admin_exec
~base_port
~pp_error
~wallet_scenario
~protocol
~client_exec
~uri) ))
$ Arg.(
required
(pos
0
(some string)
None
(info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI")))
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Tezos_executable.cli_term `Admin "tezos"
$ Arg.(value (opt int 2 (info ["size"; "S"] ~doc:"Size of the Network")))
$ Arg.(
pure (fun p -> `Base_port p)
$ value
(opt
int
32_000
(info ["base-port"; "P"] ~doc:"Base port number to build upon")))
$ Tezos_protocol.cli_term ()
$ Wallet_scenario.cli_term ()
$ Test_command_line.cli_state ~name:"ledger-wallet" () )
(let doc = "Interactive test exercising the Ledger Wallet app features" in
info ~doc "ledger-wallet")
src/bin_sandbox/command_ledger_wallet.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition client_async_cmd {A B C D E F : Type}
(state : A) (client : B) (args : list string) (f : C -> D -> E) : F :=
op_startypeminuserrorstar
(op_startypeminuserrorstar "client_async_cmd" % string state f
"sh -c %s" % string
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar client state args)
op_startypeminuserrorstar) Filename.quote))
(fun function_parameter =>
let '(status, res) := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar).
Definition ledger_hash_re {A : Type} : lazy_t A :=
(* ❌ Lazy expressions are not handled *)
lazy op_startypeminuserrorstar.
Definition find_and_print_signature_hash {A B C : Type}
(op_staroptstar : option bool) : A -> B -> C :=
let display_expectation :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun state =>
fun process =>
let re := Lazy.force ledger_hash_re in
let check {D E : Type} (lines : D) : E :=
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar process
("" % string, "" % string, (negb display_expectation))
(fun function_parameter =>
let '(all_output_prev, all_error_prev, showed_message_prev) :=
function_parameter in
fun out =>
fun err =>
let all_output := String.append all_output_prev out in
let all_error := String.append all_error_prev err in
op_startypeminuserrorstar
(if negb showed_message_prev then
match check all_output with
| None => op_startypeminuserrorstar false
| Some x =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar true)
end
else
op_startypeminuserrorstar true)
(fun showed_message =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant)))
(fun function_parameter =>
let '(output, error, _) := function_parameter in
op_startypeminuserrorstar
((op_startypeminuserrorstar "010" % char output),
(op_startypeminuserrorstar "010" % char error))).
Module MFmt.
End MFmt.
Definition failf {A B C : Type} (attach : option A) (fmt : B) : C :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar attach
(* ❌ Variants not supported *)
variant) fmt.
Definition process_should_fail {A B C : Type} (msg : A) (f : unit -> B) : C :=
op_startypeminuserrorstar
(op_startypeminuserrorstar (f tt)
(fun function_parameter =>
let '_ := function_parameter in
match
(* ❌ Sending method message is not handled *)
send with
| Unix.WEXITED 0 =>
failf
(Some
(cons
("stdout" % string,
(* ❌ Variants not supported *)
variant)
(cons
("stderr" % string,
(* ❌ Variants not supported *)
variant) []))) "Process should have failed: %s" % string msg
| _ => op_startypeminuserrorstar tt
end))
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt).
Definition ledger_prompt_notice {A B C : Type}
(state : A) (msgs : B -> unit) (op_staroptstar : option variant)
: unit -> C :=
let button :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun function_parameter =>
let 'tt := function_parameter in
let button_str :=
match button with
| Checkmark => "✔" % string
| X => "❌" % string
| Both => "❌ and ✔ at the same time" % string
end in
op_startypeminuserrorstar state
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar 4 ppf
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
(fun ppf =>
op_startypeminuserrorstar op_startypeminuserrorstar
"Ledger-prompt:" % string ppf tt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.List.iter msgs
(* ❌ expected an argument *)
expected_argument
(fun f =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := f ppf tt in
op_startypeminuserrorstar ppf tt) in
op_startypeminuserrorstar ppf
"→ Press %s on the ledger." % string button_str)).
Definition ledger_prompt_notice_expectation {A B C : Type}
(state : A) (messages : list (B -> unit -> unit)) (user_answer : variant)
: C := op_startypeminuserrorstar.
Definition with_ledger_test_reject_and_accept {A B C D : Type}
(op_staroptstar : option bool)
: A -> (list (B -> unit -> unit)) -> (variant -> C) -> D :=
let only_success :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun state =>
fun messages =>
fun f =>
let with_ledger_prompt {E F : Type}
(state : A) (messages : list (B -> unit -> unit)) (user_answer :
variant) (f : variant -> E) : F :=
op_startypeminuserrorstar
(ledger_prompt_notice_expectation state messages user_answer)
(fun function_parameter =>
let 'tt := function_parameter in
f user_answer) in
op_startypeminuserrorstar
(if only_success then
op_startypeminuserrorstar tt
else
with_ledger_prompt state messages
(* ❌ Variants not supported *)
variant f)
(fun function_parameter =>
let 'tt := function_parameter in
with_ledger_prompt state messages
(* ❌ Variants not supported *)
variant f).
Definition get_chain_id {A B C : Type} (state : A) (client : B) : C :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/chain_id" % string)
(fun function_parameter =>
match function_parameter with
| String x => op_startypeminuserrorstar x
| _ => failf None "Failed to parse chain_id JSON from node" % string
end))
(fun chain_id_string =>
op_startypeminuserrorstar (op_startypeminuserrorstar chain_id_string)).
Definition get_head_block_hash {A B C : Type}
(state : A) (client : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/blocks/head/hash" % string)
(fun function_parameter =>
match function_parameter with
| String x => op_startypeminuserrorstar x
| _ => failf None "Failed to parse block hash JSON from node" % string
end).
Definition please_check_the_hash {A B : Type}
(ppf : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar "prompt" % string ppf
(fun ppf =>
op_startypeminuserrorstar ppf
"The ledger cannot parse this operation, please verify the hash." %
string).
Definition forge_batch_transactions {A B C D E : Type}
(state : A) (client : B) (src : string) (function_parameter : C)
: D -> (option Z) -> unit -> E :=
let '_ := function_parameter in
fun n =>
fun op_staroptstar =>
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Float constant 0.00126 is approximated by the integer 0 *)
0
end in
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (get_head_block_hash state client tt)
(fun branch =>
let json :=
(* ❌ Variants not supported *)
variant in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
"/chains/main/blocks/head/helpers/forge/operations" % string
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| String operation_bytes =>
let magic_byte := "03" % string in
op_startypeminuserrorstar
(String.append magic_byte operation_bytes)
| _ =>
failf None
"Failed to forge operation or parse result" % string
end)).
Definition expect_from_output {A B : Type}
(expectation : variant) (message : string) (function_parameter : A) : B :=
let '_ := function_parameter in
let exp :=
match expectation with
| Ledger_reject_or_timeout => "rejection" % string
| Not_a_delegate => "not-delegate-error" % string
| Success => "success" % string
| Origination_failed => "origination-failure" % string
end in
let nope {C D : Type} (s : C) : D :=
failf
(Some
(cons
("stdout" % string,
(* ❌ Variants not supported *)
variant)
(cons
("stderr" % string,
(* ❌ Variants not supported *)
variant) []))) "%s, expected %s: %s." % string message exp s in
let success :=
equiv_decb
(* ❌ Sending method message is not handled *)
send (Unix.WEXITED 0) in
match expectation with
| Success => op_startypeminuserrorstar tt
| Success => nope "did not succeed" % string
| (Ledger_reject_or_timeout | Not_a_delegate | Origination_failed) as e =>
let pattern :=
match e with
| Ledger_reject_or_timeout => "Conditions of use not satisfied" % string
| Not_a_delegate => "not registered as valid delegate key" % string
| Origination_failed => "origination simulation failed" % string
end in
let all_output :=
Stdlib.String.concat op_startypeminuserrorstar
(* ❌ expected an argument *)
expected_argument "
" % string in
match (success, (op_startypeminuserrorstar all_output pattern)) with
| (false, Some _) => op_startypeminuserrorstar tt
| (false, None) => nope "cannot find the right error message" % string
| (true, _) => nope "command succeeded??" % string
end
end.
Definition voting_tests {A B C D E : Type}
(state : A) (client : Z -> B) (src : string) (with_rejections : bool)
(protocol_kind : variant) (ledger_account : C) (tested_proposal : string)
(go_to_next_period : unit -> D) (function_parameter : unit) : E :=
let 'tt := function_parameter in
let expect_success {F G : Type} (message : string) (v : F) : G :=
expect_from_output
(* ❌ Variants not supported *)
variant message v in
let expect_rejection {F G : Type} (message : string) (v : F) : G :=
expect_from_output
(* ❌ Variants not supported *)
variant message v in
let test_reject_and_accept {F G H : Type}
(name : string) (messages : list (F -> unit -> unit)) (action : unit -> G)
: H :=
op_startypeminuserrorstar
(if with_rejections then
op_startypeminuserrorstar
(ledger_prompt_notice_expectation state messages
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (action tt)
(fun res => expect_rejection name res))
else
op_startypeminuserrorstar tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(ledger_prompt_notice_expectation state messages
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (action tt)
(fun res => expect_success name res))) in
let source_display := op_startypeminuserrorstar ledger_account in
let submit_proposals {F : Type}
(display_expectation : bool) (proposals : list string) (function_parameter :
unit) : F :=
let 'tt := function_parameter in
client_async_cmd state (client 0)
(OCaml.Stdlib.app
(cons "submit" % string
(cons "proposals" % string (cons "for" % string (cons src []))))
(OCaml.Stdlib.app proposals
(cons "--force" % string (cons "--verbose-signing" % string []))))
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash (Some display_expectation) state proc)
in
op_startypeminuserrorstar
(test_reject_and_accept "single-proposal" % string
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Submitting single proposal %s" % string tested_proposal)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
match protocol_kind with
| Athens => tt
| Babylon =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
"On Babylon, You will first be asked to provide the public key."
% string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar ppf
"Accept this prompt, regardless of below, then continue." %
string
end)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf 4
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
"Protocol is %a, the ledger should be able to display voting parameters:"
% string op_startypeminuserrorstar protocol_kind in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf "* Source: `%s`" % string
source_display in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf "* Period: `0`" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar ppf "* Protocol: `%s`" % string
tested_proposal)) [])))
(submit_proposals false (cons tested_proposal [])))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_reject_and_accept "multiple-proposal" % string
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Submitting 2 proposals together" % string)
(cons please_check_the_hash []))
(submit_proposals true
(cons tested_proposal
(cons
"Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z" % string
[]))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (go_to_next_period tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(cons "yea" % string (cons "nay" % string []))
(fun n =>
fun vote =>
test_reject_and_accept
(op_startypeminuserrorstar "vote-%s" % string vote)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
match protocol_kind with
| Athens => tt
| Babylon =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
"On Babylon, You will first be asked to provide the public key."
% string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar ppf
"Accept this prompt, regardless of below, then continue."
% string
end)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Voting %s for %s" % string vote tested_proposal)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Source: `%s`" % string source_display)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Period: `%i`" % string (Z.add n 1))
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Protocol: `%s`" % string tested_proposal)
[])))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state (client 0)
(cons "submit" % string
(cons "ballot" % string
(cons "for" % string
(cons src
(cons tested_proposal (cons vote [])))))))
(fun function_parameter =>
let '(_, proc) := function_parameter in
op_startypeminuserrorstar proc)))))).
Definition ledger_should_display {A B C : Type} (ppf : A) (l : B -> unit) : C :=
op_startypeminuserrorstar 4 ppf
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf "Ledger should display:" % string
in
Stdlib.List.iter l
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '(s, f) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar ppf "* %s: %a." % string s f tt)).
Definition show_command_message {A : Type}
(command : list string) (ppf : A) (function_parameter : unit) : unit :=
let 'tt := function_parameter in
op_startypeminuserrorstar 2 ppf
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf "Command:" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar) op_startypeminuserrorstar ppf tt).
Definition sign {A B C : Type} (state : A) (client : B) (bytes : string) : C :=
op_startypeminuserrorstar state (Tezos_client.Keyed.client client)
(cons "sign" % string
(cons "bytes" % string
(cons (String.append "0x" % string string)
(cons "for" % string (cons (Tezos_client.Keyed.key_name client) []))))).
Definition delegation_tests {A B C D E : Type}
(state : A) (client : B) (src : string) (with_rejections : bool)
(protocol_kind : variant) (ledger_account : C) (delegate : string) (bake : D)
(function_parameter : unit) : E :=
let 'tt := function_parameter in
let ledger_pkh := op_startypeminuserrorstar ledger_account in
let only_success := negb with_rejections in
let self_delegation {F : Type} (function_parameter : unit) : F :=
let 'tt := function_parameter in
let command :=
cons "--wait" % string
(cons "none" % string
(cons "set" % string
(cons "delegate" % string
(cons "for" % string
(cons src
(cons "to" % string
(cons src (cons "--verbose-signing" % string [])))))))) in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Self-delegating account `%s`" % string ledger_pkh)
(cons (show_command_message command)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Note that X is a placeholder for some value that will vary between runs"
% string)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf op_startypeminuserrorstar) []))))
(fun user_answer =>
op_startypeminuserrorstar
(client_async_cmd state client command
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash
(Some
(equiv_decb protocol_kind
(* ❌ Variants not supported *)
variant)) state proc))
(fun res =>
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end "self-delegation" % string res)))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "setting self-delegate of %s" % string
src) in
let tz_account_delegation {F : Type} (function_parameter : unit) : F :=
let 'tt := function_parameter in
let command :=
cons "--wait" % string
(cons "none" % string
(cons "set" % string
(cons "delegate" % string
(cons "for" % string
(cons src
(cons "to" % string
(cons delegate (cons "--verbose-signing" % string []))))))))
in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Delegating account `%s` to `%s`" % string ledger_pkh delegate)
(cons (show_command_message command)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Note that X is a placeholder for some value that will vary between runs"
% string)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf op_startypeminuserrorstar) []))))
(fun user_answer =>
op_startypeminuserrorstar
(client_async_cmd state client command
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash
(Some
(equiv_decb protocol_kind
(* ❌ Variants not supported *)
variant)) state proc))
(fun res =>
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end "tz123-delegation" % string res)))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "setting delegate of %s" % string src) in
let run_command_and_check {F G H I : Type}
(state : F) (client : G) (command : H) (message : string) (user_answer :
variant) : I :=
op_startypeminuserrorstar (op_startypeminuserrorstar state client command)
(fun function_parameter =>
let '(_, res) := function_parameter in
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end message res) in
let delegate_with_scriptless_account {F : Type} (function_parameter : unit)
: F :=
let 'tt := function_parameter in
let originated_account_name := "ledginated" % string in
let amount := "200" % string in
let burn_cap := "0.257" % string in
let command :=
cons "--wait" % string
(cons "none" % string
(cons "originate" % string
(cons "account" % string
(cons originated_account_name
(cons "for" % string
(cons src
(cons "transferring" % string
(cons "200" % string
(cons "from" % string
(cons src
(cons "--delegatable" % string
(cons "--burn-cap" % string
(cons burn_cap (cons "--force" % string []))))))))))))))
in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf "Originating account `%s`" % string
originated_account_name)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf op_startypeminuserrorstar) []))
(fun user_answer =>
run_command_and_check state client command
"account origination" % string user_answer))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar bake "origination of %s" % string
originated_account_name)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "show" % string
(cons "known" % string
(cons "contract" % string (cons originated_account_name [])))))
(fun function_parameter =>
let '(_, proc_result) := function_parameter in
let contract_address :=
OCaml.Stdlib.reverse_apply
(* ❌ Sending method message is not handled *)
send
(Stdlib.String.concat
(* ❌ expected an argument *)
expected_argument
(* ❌ expected an argument *)
expected_argument "" % string) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "show" % string
(cons "address" % string (cons delegate []))))
(fun function_parameter =>
let '(_, proc_result) := function_parameter in
let delegate_address :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar
(* ❌ Sending method message is not handled *)
send) (op_startypeminuserrorstar " " % char))
op_startypeminuserrorstar)
(op_startypeminuserrorstar delegate) in
let command :=
cons "--wait" % string
(cons "none" % string
(cons "set" % string
(cons "delegate" % string
(cons "for" % string
(cons originated_account_name
(cons "to" % string (cons delegate [])))))))
in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success)
state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Setting `%s` as delegate for `%s`" % string
delegate originated_account_name)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf
op_startypeminuserrorstar) []))
(fun user_answer =>
run_command_and_check state client command
"setting delegate of KT1" % string user_answer))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar bake
"setting delegate of %s" % string
originated_account_name)
(fun function_parameter =>
let 'tt := function_parameter in
let withdraw_command :=
cons "--wait" % string
(cons "none" % string
(cons "withdraw" % string
(cons "delegate" % string
(cons "from" % string
(cons originated_account_name []))))) in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept
(Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Withdrawing delegate from `%s`" %
string originated_account_name)
(cons (show_command_message withdraw_command)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf
op_startypeminuserrorstar) [])))
(fun user_answer =>
run_command_and_check state client
withdraw_command
"withdrawing delegate from originated account"
% string user_answer))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar bake
"withdrawing delegate of %s" % string
originated_account_name))))))) in
match protocol_kind with
| Athens =>
op_startypeminuserrorstar (self_delegation tt)
(fun function_parameter =>
let 'tt := function_parameter in
delegate_with_scriptless_account tt)
| Babylon =>
op_startypeminuserrorstar (tz_account_delegation tt)
(fun function_parameter =>
let 'tt := function_parameter in
self_delegation tt)
end.
Definition transaction_tests {A B C D E : Type}
(state : A) (client : B) (src : string) (with_rejections : bool)
(protocol_kind : variant) (pair_string_nat_kt1_account : string)
(ledger_account : C) (unit_kt1_account : string) (bake : D)
(function_parameter : unit) : E :=
let 'tt := function_parameter in
let ledger_pkh := op_startypeminuserrorstar ledger_account in
let only_success := negb with_rejections in
let test_transaction {F G H : Type} (op_staroptstar : option Z)
: (option F) -> string -> string -> G -> unit -> H :=
let storage :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun arguments =>
fun name =>
fun dst_name =>
fun dst_pkh =>
fun function_parameter =>
let 'tt := function_parameter in
let amount := "15" % string in
let command :=
OCaml.Stdlib.app
(cons "--wait" % string
(cons "none" % string
(cons "transfer" % string
(cons amount
(cons "from" % string
(cons src (cons "to" % string (cons dst_name []))))))))
(OCaml.Stdlib.app
(op_startypeminuserrorstar [] arguments
(fun a => cons "--arg" % string (cons a [])))
(cons "--burn-cap" % string
(cons "100" % string
(cons "--verbose-signing" % string [])))) in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"%s with account `%s`" % string name ledger_pkh)
(cons (show_command_message command)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Note that X is a placeholder for some value that will vary between runs"
% string)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
match arguments with
| None =>
ledger_should_display ppf
op_startypeminuserrorstar
| _ => please_check_the_hash ppf tt
end) []))))
(fun user_answer =>
op_startypeminuserrorstar
(client_async_cmd state client command
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash
(Some
(orb
(equiv_decb protocol_kind
(* ❌ Variants not supported *)
variant) (nequiv_decb arguments None)))
state proc))
(fun res =>
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end name res)))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "%s with %s" % string name src)
in
op_startypeminuserrorstar
(test_transaction None None "Self-transaction" % string src ledger_pkh tt)
(fun function_parameter =>
let 'tt := function_parameter in
let Acc :=
(* ❌ The signature name of this module could not be found *)
existT _ _
{|
|} in
let random_account :=
op_startypeminuserrorstar "random-account-for-transaction-test" % string
in
op_startypeminuserrorstar
(test_transaction (Some 277) None "transaction-to-random-tz1" % string
(op_startypeminuserrorstar random_account)
(op_startypeminuserrorstar random_account) tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_transaction (Some 0) None
"transaction-to-random-tz1-again" % string
(op_startypeminuserrorstar random_account)
(op_startypeminuserrorstar random_account) tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_transaction None None
"parameterless-transaction-to-kt1" % string unit_kt1_account
"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
test_transaction None
(Some "Pair ""hello from the ledger"" 51" % string)
"parameterfull-transaction-to-kt1" % string
pair_string_nat_kt1_account
"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" % string tt)))).
Definition prepare_origination_of_id_script {A B C D : Type}
(op_staroptstar : option bool)
: (option bool) ->
(option A) ->
(option Z) ->
(option string) ->
B -> C -> string -> string -> variant -> string -> string -> D :=
let spendable :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let delegatable :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun delegate =>
fun op_staroptstar =>
let push_drops :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun op_staroptstar =>
let amount :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "2" % string
end in
fun state =>
fun function_parameter =>
let '_ := function_parameter in
fun name =>
fun from =>
fun protocol_kind =>
fun parameter =>
fun init_storage =>
let id_script {E : Type} (parameter : string) : E :=
op_startypeminuserrorstar
"parameter %s;
storage %s;
code
{
%s
{ CAR; NIL operation; PAIR }
};
"
% string parameter parameter
match push_drops with
| 0 => "# No push-drops" % string
| n =>
op_startypeminuserrorstar
"# %d push-drop%s
%s" % string n
(if OCaml.Stdlib.gt n 1 then
"s" % string
else
"" % string) op_startypeminuserrorstar
end in
let tmp :=
Filename.temp_file None "little-id-script" % string
".tz" % string in
op_startypeminuserrorstar
(op_startypeminuserrorstar state tmp
(id_script parameter))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
op_startypeminuserrorstar in
let origination :=
let opt := op_startypeminuserrorstar [] in
OCaml.Stdlib.app
(cons "--wait" % string
(cons "none" % string
(cons "originate" % string
(cons "contract" % string (cons name [])))))
(OCaml.Stdlib.app
match protocol_kind with
| Athens => cons "for" % string (cons from [])
| Babylon => []
end
(OCaml.Stdlib.app
(cons "transferring" % string
(cons amount
(cons "from" % string
(cons from
(cons "running" % string
(cons tmp
(cons "--init" % string
(cons init_storage
(cons "--force" % string
(cons
"--burn-cap" % string
(cons
"300000000000" %
string
(cons
"--gas-limit" %
string
(cons
"1000000000000000"
% string
(cons
"--storage-limit"
% string
(cons
"20000000000000"
% string
(cons
"--verbose-signing"
% string
[]))))))))))))))))
(OCaml.Stdlib.app
(opt delegate
(fun s =>
cons "--delegate" % string (cons s [])))
(OCaml.Stdlib.app
(if delegatable then
cons "--delegatable" % string []
else
[])
(if spendable then
cons "--spendable" % string []
else
[]))))) in
op_startypeminuserrorstar origination).
Definition originate_id_script {A B C D : Type}
(push_drops : option Z) (state : A) (client : B) (name : string)
(from : string) (bake : C) (protocol_kind : variant) (parameter : string)
(init_storage : string) : D :=
op_startypeminuserrorstar
(prepare_origination_of_id_script None None None push_drops None state
client name from protocol_kind parameter init_storage)
(fun origination =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client origination)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "baking `%s` in" % string name)).
Definition pp_warning_ledger_takes_a_while {A B C : Type}
(adjective : A) (ppf : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
let prompt := "WARNING: " % string in
let warning1 := "The ledger will take a few seconds to show" % string in
let warning2 :=
op_startypeminuserrorstar "the hash for such a %s operation." % string
adjective in
let wl := Z.add (OCaml.String.length prompt) (OCaml.String.length warning1) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf =>
op_startypeminuserrorstar ppf
(String.append "/" % string
(String.append (Stdlib.String.make wl "=" % char) "\" % string))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf => op_startypeminuserrorstar ppf "|%s" % string prompt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf warning1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf => op_startypeminuserrorstar ppf "|" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf => op_startypeminuserrorstar ppf "|" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
(Stdlib.String.make (OCaml.String.length prompt) " " % char) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf warning2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
(Stdlib.String.make
(Z.sub (OCaml.String.length warning1) (OCaml.String.length warning2))
" " % char) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf => op_startypeminuserrorstar ppf "|" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar "shout" % string ppf
(fun ppf =>
op_startypeminuserrorstar ppf
(String.append "\" % string
(String.append (Stdlib.String.make wl "=" % char) "/" % string))).
Definition basic_contract_operations_tests {A B C D E F : Type}
(state : A) (client : B) (src : string) (with_rejections : bool)
(protocol_kind : variant) (ledger_account : C) (bake : D) (delegate : E)
(function_parameter : unit) : F :=
let 'tt := function_parameter in
let ledger_pkh := op_startypeminuserrorstar ledger_account in
let only_success := negb with_rejections in
let test_origination {G : Type}
(delegate : option E) (delegatable : option bool) (spendable : option bool)
(push_drops : option Z) (name : string) (amount : string) (parameter :
string) (init_storage : string) (function_parameter : unit) : G :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(prepare_origination_of_id_script spendable delegatable delegate
push_drops (Some amount) state client name src protocol_kind parameter
init_storage)
(fun origination =>
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Origination: %s (ledger: %s)" % string name ledger_pkh)
(cons (show_command_message origination)
(cons please_check_the_hash
(cons
(if nequiv_decb push_drops None then
pp_warning_ledger_takes_a_while "huge" % string
else
op_startypeminuserrorstar op_startypeminuserrorstar
"" % string) []))))
(fun user_answer =>
op_startypeminuserrorstar
(client_async_cmd state client origination
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash (Some true) state proc))
(fun res =>
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end name res)))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "%s with %s" % string name src)) in
op_startypeminuserrorstar
(test_origination None None None None "ID-unit" % string "0" % string
"unit" % string "Unit" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_origination None None None None "ID-string" % string "10" % string
"string" % string """some string""" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_origination None None None None "ID-string-nat-mutez" % string
"10" % string "(pair string (pair nat mutez))" % string
"Pair ""hello"" (Pair 12 1)" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_origination (Some delegate) None None None
"ID-address+delegate" % string "1" % string "address" % string
"""tz1YPSCGWXwBdTncK2aCctSZAXWvGsGwVJqU""" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
match protocol_kind with
| Athens =>
test_origination (Some delegate) (Some true) None None
"ID-string+delegatable" % string "0" % string
"string" % string """delegatable contract""" % string tt
| Babylon => op_startypeminuserrorstar tt
end
(fun function_parameter =>
let 'tt := function_parameter in
let push_drops := 242 in
test_origination None None None (Some push_drops)
"giant-contract" % string "10" % string
"(pair string nat)" % string
"Pair ""the answer is: "" 42" % string tt))))).
Module Wallet_scenario.
Definition root := variant.
Definition t := variant.
Definition with_rejections (function_parameter : t) : bool :=
match function_parameter with
| Without_rejections _ => false
| _ => true
end.
Definition enum_assoc : list (string * root) :=
cons
("everything" % string,
(* ❌ Variants not supported *)
variant)
(cons
("voting" % string,
(* ❌ Variants not supported *)
variant)
(cons
("none" % string,
(* ❌ Variants not supported *)
variant)
(cons
("delegation" % string,
(* ❌ Variants not supported *)
variant)
(cons
("transactions" % string,
(* ❌ Variants not supported *)
variant)
(cons
("contracts" % string,
(* ❌ Variants not supported *)
variant)
(cons
("batch-transactions" % string,
(* ❌ Variants not supported *)
variant) [])))))).
Definition root (ws : t) : root :=
match ws with
| Without_rejections r => r
|
(Transactions |
Delegation | Contracts | All | Batch_transactions | None | Voting) as r
=> r
end.
Definition run_if {A B : Type}
(v : root) (t : t) (yes : bool -> A) (no : B -> A) : A :=
let with_rejections := with_rejections t in
match root t with
| All => yes with_rejections
| other => yes with_rejections
| _other =>
no
(op_startypeminuserrorstar enum_assoc
(fun function_parameter =>
match function_parameter with
| (k, this) => Some k
| _ => None
end))
end.
Definition if_voting {A B : Type} (t : t) : (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition if_batch_transactions {A B : Type} (t : t)
: (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition if_delegation {A B : Type} (t : t)
: (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition if_transactions {A B : Type} (t : t)
: (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition if_contracts {A B : Type} (t : t) : (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition cli_term {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
let make (no_rejections : bool) (v : root) : t :=
if no_rejections then
(* ❌ Variants not supported *)
variant
else
v in
op_startypeminuserrorstar.
End Wallet_scenario.
Definition run {A B C D E F G H : Type}
(state : A) (pp_error : Stdlib.Format.formatter -> B -> unit) (protocol : C)
(protocol_kind : variant) (node_exec : D) (client_exec : D) (admin_exec : D)
(wallet_scenario : Wallet_scenario.t) (size : E) (base_port : F) (uri : G)
(function_parameter : unit) : H :=
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(* ❌ Variants not supported *)
variant (cons node_exec (cons client_exec (cons admin_exec []))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let ledger_client := op_startypeminuserrorstar client_exec in
op_startypeminuserrorstar
(op_startypeminuserrorstar state ledger_client uri)
(fun _ledger_account =>
let '(protocol, baker_0_account, _baker_0_balance) :=
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar protocol size base_port state
node_exec client_exec)
(fun function_parameter =>
let '(nodes, protocol) := function_parameter in
let client {I J : Type} (n : I) : J :=
op_startypeminuserrorstar client_exec
(op_startypeminuserrorstar nodes n) in
let client_0 := client 0 in
let baker_0 :=
op_startypeminuserrorstar client_0 "baker-0" % string
(op_startypeminuserrorstar baker_0_account) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0)
(fun function_parameter =>
let '_ := function_parameter in
let make_admin := op_startypeminuserrorstar admin_exec
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
let first_bakes := 3 in
op_startypeminuserrorstar
(op_startypeminuserrorstar first_bakes
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0)
"initial-bake %d" % string nth))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let signer :=
op_startypeminuserrorstar (client 0)
"ledgered" % string uri in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client_0
uri)
(fun ledger_account =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
client_0
(cons "--wait" % string
(cons "none" % string
(cons "transfer" % string
(cons "20000" % string
(cons "from" % string
(cons
(Tezos_client.Keyed.key_name
baker_0)
(cons "to" % string
(cons
(op_startypeminuserrorstar
ledger_account)
(cons
"--burn-cap" %
string
(cons "100" % string
[])))))))))))
(fun function_parameter =>
let '_ := function_parameter in
let bake {I J : Type} (msg : I) : J :=
op_startypeminuserrorstar state
baker_0 msg in
op_startypeminuserrorstar
(bake
"After transferring tez to the ledger account"
% string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept
(Some
(OCaml.Stdlib.reverse_apply
(Wallet_scenario.with_rejections
wallet_scenario) negb))
state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
ppf
"Importing %S in client `%s`."
% string uri
(Tezos_client.id
client_0))
(cons
(fun ppf =>
fun function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
ppf
"The ledger should be prompting for acknowledgment to provide the public key of `%s`."
% string
(op_startypeminuserrorstar
ledger_account))
[]))
(fun user_answer =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state client_0
(cons "import" % string
(cons
"secret" % string
(cons "key" % string
(cons
(key_name signer)
(cons
(secret_key
signer)
(cons
"--force" %
string [])))))))
(fun function_parameter =>
let '(_, proc) :=
function_parameter in
expect_from_output
match user_answer with
| Accept =>
(* ❌ Variants not supported *)
variant
| Reject =>
(* ❌ Variants not supported *)
variant
end
"importing key" %
string proc)))
(fun function_parameter =>
let 'tt := function_parameter
in
let skipping {I J : Type}
(s : I) : J :=
op_startypeminuserrorstar
state
op_startypeminuserrorstar
in
let voting_test {I : Type}
(with_rejections : bool)
: I :=
let tested_proposal :=
"Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd"
% string in
voting_tests state client
(key_name signer)
with_rejections
protocol_kind
ledger_account
tested_proposal
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state client_0
(cons
"--wait" % string
(cons
"none" % string
(cons
"submit" %
string
(cons
"proposals"
% string
(cons
"for" %
string
(cons
(Tezos_client.Keyed.key_name
baker_0)
(cons
tested_proposal
(cons
"--force"
%
string
[])))))))))
(fun
function_parameter
=>
let '_ :=
function_parameter
in
let blocks :=
Tezos_protocol.blocks_per_voting_period
protocol in
op_startypeminuserrorstar
(op_startypeminuserrorstar
blocks
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0)
"going to testing-vote period %d/%d"
% string
(Z.add nth 1)
blocks))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
tt))) tt in
let batch_test {I : Type}
(with_rejections : bool)
: I :=
let n := 50 in
op_startypeminuserrorstar
(forge_batch_transactions
state (client 0)
(op_startypeminuserrorstar
ledger_account)
"tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F"
% string n None tt)
(fun
batch_transaction_bytes
=>
let bytes_hash :=
op_startypeminuserrorstar
in
with_ledger_test_reject_and_accept
(Some
(negb
with_rejections))
state
(cons
(fun ppf =>
fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
ppf
"Signing batch of %d transactions"
% string n)
(cons
(fun ppf =>
fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
ppf
"Ledger should display “Sign Hash” → `%s`"
% string
bytes_hash)
(cons
(pp_warning_ledger_takes_a_while
"big" % string)
[])))
(fun user_answer =>
op_startypeminuserrorstar
(sign state signer
batch_transaction_bytes)
(fun
function_parameter
=>
let
'(_, proc) :=
function_parameter
in
expect_from_output
match
user_answer
with
| Accept =>
(* ❌ Variants not supported *)
variant
| Reject =>
(* ❌ Variants not supported *)
variant
end
"Signing batch operation"
% string
proc))) in
let delegation_tests
{I : Type}
(with_rejections : bool)
: I :=
delegation_tests state
client_0 (key_name signer)
with_rejections
protocol_kind
ledger_account
(Tezos_client.Keyed.key_name
baker_0) bake tt in
let unit_kt1_account :=
"unit-kt1-of-the-baker" %
string in
op_startypeminuserrorstar
(originate_id_script None
state client_0
unit_kt1_account
(Tezos_client.Keyed.key_name
baker_0) bake
protocol_kind
"unit" % string
"Unit" % string)
(fun function_parameter =>
let 'tt :=
function_parameter in
let
pair_string_nat_kt1_account :=
"pair-string-nat-kt1-of-the-baker"
% string in
op_startypeminuserrorstar
(originate_id_script
(Some 10) state
client_0
pair_string_nat_kt1_account
(Tezos_client.Keyed.key_name
baker_0) bake
protocol_kind
"(pair string nat)" %
string
"Pair ""the answer is: "" 42"
% string)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
let transactions_test
{I : Type}
(with_rejections :
bool) : I :=
transaction_tests
state client_0
(key_name signer)
with_rejections
protocol_kind
pair_string_nat_kt1_account
ledger_account
unit_kt1_account
bake tt in
let contracts_test
{I : Type}
(with_rejections :
bool) : I :=
basic_contract_operations_tests
state client_0
(key_name signer)
with_rejections
protocol_kind
ledger_account
bake
(Tezos_client.Keyed.key_name
baker_0) tt in
let bake_command :=
op_startypeminuserrorstar
op_startypeminuserrorstar
(cons
"bake" % string
[])
(fun _sexps =>
op_startypeminuserrorstar
(fun e =>
Format.kasprintf
(fun s =>
(* ❌ Variants not supported *)
variant)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"run-test-error: "
%
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"run-test-error: %a"
%
string)
pp_error e)
(bake
"Interactive"
% string))
in
let
run_test_command :=
op_startypeminuserrorstar
op_startypeminuserrorstar
(cons
"rt" % string
(cons
"run-test" %
string []))
(fun sexps =>
op_startypeminuserrorstar
(fun e =>
Format.kasprintf
(fun s =>
(* ❌ Variants not supported *)
variant)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"run-test-error: "
%
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"run-test-error: %a"
%
string)
pp_error e)
match sexps
with
| _ =>
let run
{I : Type}
(f :
bool -> I)
: I :=
f true in
match
op_startypeminuserrorstar
Stdlib.String.equal
Wallet_scenario.enum_assoc
op_startypeminuserrorstar
with
| Some None
=>
op_startypeminuserrorstar
tt
|
Some
Delegation
=>
run
delegation_tests
| Some All
=>
op_startypeminuserrorstar
(run
delegation_tests)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(run
batch_test)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
run
voting_test))
|
Some
Batch_transactions
=>
run
batch_test
|
Some
Transactions
=>
run
transactions_test
|
Some
Voting
=>
run
voting_test
|
Some
Contracts
=>
run
contracts_test
| None =>
failf None
"Don't know this test: %S"
%
string
op_startypeminuserrorstar
end
| _ =>
failf None
"Cannot understand command line"
% string
end) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
state
(cons
run_test_command
(cons
bake_command
[])) in
op_startypeminuserrorstar
(Wallet_scenario.if_voting
wallet_scenario
voting_test
skipping)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(Wallet_scenario.if_batch_transactions
wallet_scenario
batch_test
skipping)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(Wallet_scenario.if_transactions
wallet_scenario
transactions_test
skipping)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(Wallet_scenario.if_contracts
wallet_scenario
contracts_test
skipping)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(Wallet_scenario.if_delegation
wallet_scenario
delegation_tests
skipping)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_prevalidation.ml 17 errors
open Flextesa
open Internal_pervasives
open Console
let run state node_exec client_exec () =
Test_scenario.network_with_protocol ~size:2 state ~node_exec ~client_exec
>>= fun (nodes, _protocol) ->
match nodes with
| [] | [_] | _ :: _ :: _ :: _ ->
assert false
| [n1; n2] ->
let c1 = Tezos_client.of_node ~exec:client_exec n1 in
let c2 = Tezos_client.of_node ~exec:client_exec n2 in
(* TODO: helpers for
- injecting an op
- displaying the mempool
- setting filter plugin config
TODO: non-interactive test for propagation
TODO: commands for interactivea use *)
Pervasives.ignore c1 ;
Pervasives.ignore c2 ;
return ()
>>= fun () ->
let commands = Interactive_test.Commands.all_defaults state ~nodes in
Prompt.command state ~commands
>>= fun () -> Running_processes.wait_all state
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure (fun bnod bcli state -> (state, run state bnod bcli))
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Test_command_line.cli_state ~name:"prevalidation" () )
(info ~doc:"Work-in-progress." "prevalidation")
src/bin_sandbox/command_prevalidation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition run {A B C D : Type}
(state : A) (node_exec : B) (client_exec : C) (function_parameter : unit)
: D :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar 2 state node_exec client_exec)
(fun function_parameter =>
let '(nodes, _protocol) := function_parameter in
match nodes with
| [] | cons _ [] | cons _ (cons _ (cons _ _)) =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons n1 (cons n2 []) =>
let c1 := op_startypeminuserrorstar client_exec n1 in
let c2 := op_startypeminuserrorstar client_exec n2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Pervasives.ignore c1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Pervasives.ignore c2 in
op_startypeminuserrorstar (op_startypeminuserrorstar tt)
(fun function_parameter =>
let 'tt := function_parameter in
let commands := op_startypeminuserrorstar state nodes in
op_startypeminuserrorstar (op_startypeminuserrorstar state commands)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state))
end).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_voting.ml 423 errors
(* Semi-interactive test for voting *)
open Flextesa
open Internal_pervasives
module Counter_log = Helpers.Counter_log
let ledger_prompt_notice state ef =
Console.say
state
EF.(
desc
(shout "Ledger-prompt")
(list [ef; wf "Please hit âââ on the ledger."]))
let setup_baking_ledger state uri ~client =
Interactive_test.Pauser.generic
state
EF.
[ wf "Setting up the ledger device %S" uri;
haf
"Please make sure the ledger is on the Baking app and quit (`q`) \
this prompt to continue." ]
~force:true
>>= fun () ->
let key_name = "ledgered" in
let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in
ledger_prompt_notice
state
EF.(
wf
"Importing %S in client `%s`. The ledger should be prompting for \
acknowledgment to provide the public key."
uri
client.Tezos_client.id)
>>= fun () ->
Tezos_client.Keyed.initialize state baker
>>= fun _ ->
ledger_prompt_notice
state
EF.(
wf
"Setting up %S for baking. The ledger should be showing the setup \
parameters (Address, Main chain, HWMs)."
uri)
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client
[ "setup";
"ledger";
"to";
"bake";
"for";
key_name;
"--main-hwm";
"0";
"--test-hwm";
"0" ]
>>= fun _ -> return baker
let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt
let transfer state ~client ~src ~dst ~amount =
Tezos_client.successful_client_cmd
state
~client
[ "--wait";
"none";
"transfer";
sprintf "%Ld" amount;
"from";
src;
"to";
dst;
"--fee";
"0.05";
"--burn-cap";
"0.3" ]
let register state ~client ~dst =
Tezos_client.successful_client_cmd
state
~client
[ "--wait";
"none";
"register";
"key";
dst;
"as";
"delegate";
"--fee";
"0.05" ]
let bake_until_voting_period ?keep_alive_delegate state ~baker ~attempts period
=
let client = baker.Tezos_client.Keyed.client in
let period_name = Tezos_protocol.Voting_period.to_string period in
Helpers.wait_for state ~attempts ~seconds:0.5 (fun nth ->
Tezos_client.rpc
state
~client
`Get
~path:"/chains/main/blocks/head/votes/current_period_kind"
>>= function
| `String p when p = period_name ->
return (`Done (nth - 1))
| _ ->
Asynchronous_result.map_option keep_alive_delegate ~f:(fun dst ->
register state ~client ~dst)
>>= fun _ ->
ksprintf
(Tezos_client.Keyed.bake state baker)
"Baker %s bakes %d/%d waiting for %S voting period"
client.id
nth
attempts
period_name
>>= fun () ->
return (`Not_done (sprintf "Waiting for %S period" period_name)))
let check_understood_protocols state ~chain ~client ~protocol_hash
~expect_clueless_client =
Asynchronous_result.bind_on_result
(Tezos_client.successful_client_cmd
state
~client
["--chain"; chain; "list"; "understood"; "protocols"])
~f:(function
| Ok client_protocols_result -> (
match
List.find client_protocols_result#out ~f:(fun prefix ->
String.is_prefix protocol_hash ~prefix)
with
| Some _ ->
return `Proper_understanding
| None when expect_clueless_client ->
return `Expected_misunderstanding
| None ->
return `Failure_to_understand )
| Error (`Client_command_error _) when expect_clueless_client ->
return `Expected_misunderstanding
| Error e ->
fail e)
let run state ~winner_path ~demo_path ~protocol ~node_exec ~client_exec
~clueless_winner ~admin_exec ~winner_client_exec ~size ~base_port
~serialize_proposals ?with_ledger () =
let default_attempts = 50 in
Helpers.clear_root state
>>= fun () ->
Helpers.System_dependencies.precheck
state
`Or_fail
~executables:[node_exec; client_exec; admin_exec; winner_client_exec]
~protocol_paths:[winner_path; demo_path]
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[af "Ready to start"; af "Root path deleted."]
>>= fun () ->
let (protocol, baker_0_account, baker_0_balance) =
let open Tezos_protocol in
let baker = List.nth_exn protocol.bootstrap_accounts 0 in
( {
protocol with
time_between_blocks = [1; 0];
bootstrap_accounts =
List.map protocol.bootstrap_accounts ~f:(fun (n, v) ->
if fst baker = n then (n, v) else (n, 1_000L));
},
fst baker,
snd baker )
in
Test_scenario.network_with_protocol
~protocol
~size
~base_port
state
~node_exec
~client_exec
>>= fun (nodes, protocol) ->
let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
@ arbitrary_commands_for_each_and_all_clients
state
~make_admin
~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
>>= fun () ->
let client n =
Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
in
let baker_0 =
Tezos_client.Keyed.make
(client 0)
~key_name:"baker-0"
~secret_key:(Tezos_protocol.Account.private_key baker_0_account)
in
Tezos_client.Keyed.initialize state baker_0
>>= fun _ ->
let level_counter = Counter_log.create () in
let first_bakes = 5 in
Loop.n_times first_bakes (fun nth ->
ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth)
>>= fun () ->
let initial_level = first_bakes + 1 in
Counter_log.add level_counter "initial_level" initial_level ;
( match with_ledger with
| None ->
Console.say state EF.(wf "No ledger.")
>>= fun () ->
let account = Tezos_protocol.Account.of_name "special-baker" in
let baker =
Tezos_client.Keyed.make
(client 0)
~key_name:(Tezos_protocol.Account.name account)
~secret_key:(Tezos_protocol.Account.private_key account)
in
Tezos_client.Keyed.initialize state baker >>= fun _ -> return baker
| Some uri ->
setup_baking_ledger state ~client:(client 0) uri )
>>= fun special_baker ->
let winner_client = {baker_0.client with exec = winner_client_exec} in
let winner_baker_0 =
let open Tezos_client.Keyed in
{baker_0 with client = winner_client}
in
let winner_special_baker =
let open Tezos_client.Keyed in
{special_baker with client = winner_client}
in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.
[ arbitrary_command_on_all_clients
state
~command_names:["wc"; "winner-client"]
?make_admin:None
~clients:[winner_client] ] ;
Interactive_test.Pauser.generic
state
EF.[wf "You can now try the new-client"]
>>= fun () ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.
[ arbitrary_command_on_all_clients
state
~command_names:["baker"]
~make_admin
~clients:[special_baker.Tezos_client.Keyed.client] ] ;
transfer
state (* Tezos_client.successful_client_cmd state *)
~client:(client 0)
~amount:(Int64.div baker_0_balance 2_000_000L)
~src:"baker-0"
~dst:special_baker.Tezos_client.Keyed.key_name
>>= fun res ->
Console.say
state
EF.(
desc
(wf "Successful transfer baker-0 -> special:")
(ocaml_string_list res#out))
>>= fun () ->
let after_transfer_bakes = 2 in
Loop.n_times after_transfer_bakes (fun nth ->
ksprintf
(Tezos_client.Keyed.bake state baker_0)
"after-transfer-bake %d"
nth)
>>= fun () ->
Counter_log.add level_counter "after-transfer-bakes" after_transfer_bakes ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
ledger_prompt_notice state EF.(wf "Registering as delegate."))
>>= fun (_ : unit option) ->
Tezos_client.successful_client_cmd
state
~client:(client 0)
[ "--wait";
"none";
"register";
"key";
special_baker.Tezos_client.Keyed.key_name;
"as";
"delegate";
"--fee";
"0.5" ]
>>= fun _ ->
let activation_bakes =
let open Tezos_protocol in
protocol.blocks_per_cycle * (protocol.preserved_cycles + 2)
in
Loop.n_times activation_bakes (fun nth ->
ksprintf
(Tezos_client.Keyed.bake state baker_0)
"Baking after new delegate registered: %d/%d"
nth
activation_bakes
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client:(client 0)
["rpc"; "get"; "/chains/main/blocks/head/helpers/baking_rights"]
>>= fun res ->
Console.say
state
EF.(
desc
(haf "Baking rights")
(markdown_verbatim (String.concat ~sep:"\n" res#out))))
>>= fun () ->
Counter_log.add level_counter "activation-bakes" activation_bakes ;
Tezos_client.Keyed.bake state special_baker "Baked by Special Bakerâ¢"
>>= fun () ->
Counter_log.incr level_counter "special-baker-first-bake" ;
let attempts =
Tezos_protocol.(
(* If we are right after the proposal period, we need to get to
the next one *)
3 * protocol.blocks_per_voting_period)
in
bake_until_voting_period
state
~baker:special_baker
~attempts
`Proposal
~keep_alive_delegate:baker_0.key_name
>>= fun extra_bakes_waiting_for_proposal_period ->
Counter_log.add
level_counter
"wait-for-proposal-period"
extra_bakes_waiting_for_proposal_period ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
let admin_0 = Tezos_admin_client.of_client ~exec:admin_exec (client 0) in
Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"]
>>= fun res ->
let default_protocols = res#out in
let make_and_inject_protocol ?(make_different = false) name path =
let tmpdir = Paths.root state // sprintf "protocol-%s" name in
Console.say state EF.(wf "Injecting protocol from %s" tmpdir)
>>= fun () ->
Running_processes.run_successful_cmdf
state
"cp -L -R %s %s"
(Filename.quote path)
(Filename.quote tmpdir)
>>= fun _ ->
( if make_different then
Running_processes.run_successful_cmdf
state
"echo '(* Protocol %s *)' >> %s/main.mli"
name
(Filename.quote tmpdir)
>>= fun _ -> return ()
else return () )
>>= fun () ->
Tezos_admin_client.inject_protocol admin_0 state ~path:tmpdir
>>= fun (res, hash) ->
Interactive_test.Pauser.generic
state
EF.
[ af "Just injected %s (%s): %s" name path hash;
markdown_verbatim (String.concat ~sep:"\n" res#out) ]
>>= fun () -> return hash
in
make_and_inject_protocol "winner" winner_path
>>= fun winner_hash ->
make_and_inject_protocol
~make_different:(winner_path = demo_path)
"demo"
demo_path
>>= fun demo_hash ->
Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"]
>>= fun res ->
let after_injections_protocols = res#out in
Interactive_test.Pauser.generic
state
EF.
[ af "Network up";
desc (haf "Protcols")
@@ list
(List.map after_injections_protocols ~f:(fun p ->
af
"`%s` (%s)"
p
( if List.mem default_protocols p ~equal:String.equal then
"previously known"
else
match p with
| _ when p = winner_hash ->
"injected winner"
| _ when p = demo_hash ->
"injected demo"
| _ ->
"injected unknown" ))) ]
>>= fun () ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to VOTE";
haf "Please switch to the Wallet app and quit (`q`) this prompt."
]
~force:true)
>>= fun (_ : unit option) ->
let submit_proposals baker props =
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
ledger_prompt_notice
state
EF.(
wf
"Submitting proposal%s: %s"
(if List.length props = 1 then "" else "s")
(String.concat ~sep:", " props)))
>>= fun _ ->
Tezos_client.successful_client_cmd
state
~client:baker.Tezos_client.Keyed.client
(["submit"; "proposals"; "for"; baker.key_name] @ props)
>>= fun _ -> return ()
in
let to_submit_first = [winner_hash; demo_hash] in
( match serialize_proposals with
| false ->
submit_proposals special_baker to_submit_first
| true ->
List_sequential.iter to_submit_first ~f:(fun one ->
submit_proposals special_baker [one]) )
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client:baker_0.client
["submit"; "proposals"; "for"; baker_0.key_name; winner_hash]
>>= fun _ ->
bake_until_voting_period
state
~baker:baker_0
~attempts:protocol.blocks_per_voting_period
`Testing_vote
~keep_alive_delegate:special_baker.key_name
>>= fun extra_bakes_waiting_for_testing_vote_period ->
Counter_log.add
level_counter
"wait-for-testing-vote-period"
extra_bakes_waiting_for_testing_vote_period ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
Helpers.wait_for state ~attempts:default_attempts ~seconds:2. (fun _ ->
Tezos_client.rpc
state
~client:(client 1)
`Get
~path:"/chains/main/blocks/head/votes/current_proposal"
>>= fun current_proposal_json ->
if current_proposal_json <> `String winner_hash then
return
(`Not_done
(sprintf
"Waiting for current_proposal_json to be %s (%s)"
winner_hash
Ezjsonm.(to_string (wrap current_proposal_json))))
else return (`Done ()))
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client:baker_0.client
["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"]
>>= fun _ ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
ledger_prompt_notice
state
EF.(wf "Submitting âYesâ ballot for %S" winner_hash))
>>= fun (_ : unit option) ->
Tezos_client.successful_client_cmd
state
~client:special_baker.client
["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"]
>>= fun _ ->
Interactive_test.Pauser.generic
state
EF.[af "Ballots are in (not baked though)"]
>>= fun () ->
bake_until_voting_period
state
~baker:baker_0
~attempts:(1 + protocol.blocks_per_voting_period)
~keep_alive_delegate:special_baker.key_name
`Testing
>>= fun extra_bakes_waiting_for_testing_period ->
Counter_log.add
level_counter
"wait-for-testing-period"
extra_bakes_waiting_for_testing_period ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
check_understood_protocols
state
~client:winner_client
~chain:"main"
~protocol_hash:winner_hash
~expect_clueless_client:clueless_winner
>>= (function
| `Proper_understanding ->
let chain = "test" in
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to bake on the test chain.";
haf
"Please switch back to the Baking app and quit (`q`) \
this prompt." ]
~force:true)
>>= fun (_ : unit option) ->
let testing_bakes = 5 in
Loop.n_times testing_bakes (fun ith ->
let baker =
if ith mod 2 = 0 then winner_baker_0
else winner_special_baker
in
Tezos_client.Keyed.bake
~chain
state
baker
(sprintf
"Baking on the test chain [%d/%d]"
(ith + 1)
testing_bakes))
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~chain
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter + testing_bakes))
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[wf "Testing period, with proper winner-client, have fun."]
>>= fun () -> return ()
| `Expected_misunderstanding ->
Console.say
state
EF.(wf "Winner-Client cannot bake on test chain (expected)")
| `Failure_to_understand ->
failf "Winner-Client cannot bake on test chain!")
>>= fun () ->
Helpers.wait_for state ~attempts:default_attempts ~seconds:0.3 (fun _ ->
Tezos_client.rpc
state
~client:(client 1)
`Get
~path:"/chains/main/blocks/head/metadata"
>>= fun metadata_json ->
try
match
Jqo.field metadata_json ~k:"test_chain_status"
|> Jqo.field ~k:"protocol"
with
| `String s when s = winner_hash ->
return (`Done ())
| other ->
return
(`Not_done
(sprintf "Wrong protocol: %s" Ezjsonm.(to_string (wrap other))))
with e ->
return
(`Not_done
(sprintf
"Cannot get test-chain protocol: %s â %s"
(Exn.to_string e)
Ezjsonm.(to_string (wrap metadata_json)))))
>>= fun () ->
bake_until_voting_period
state
~baker:baker_0
~attempts:(1 + protocol.blocks_per_voting_period)
~keep_alive_delegate:special_baker.key_name
`Promotion_vote
>>= fun extra_bakes_waiting_for_promotion_period ->
Counter_log.add
level_counter
"wait-for-promotion-period"
extra_bakes_waiting_for_promotion_period ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
Interactive_test.Pauser.generic state EF.[haf "Before ballots"]
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client:baker_0.client
["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"]
>>= fun _ ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to cast approval ballot.";
haf
"Please switch back to the Wallet app and quit (`q`) this prompt."
]
~force:true
>>= fun () ->
ledger_prompt_notice
state
EF.(wf "Submitting âYesâ ballot for %S" winner_hash))
>>= fun (_ : unit option) ->
Tezos_client.successful_client_cmd
state
~client:special_baker.client
["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"]
>>= fun _ ->
Interactive_test.Pauser.generic
state
EF.[af "Final ballot(s) are in (not baked though)"]
>>= fun () ->
let ballot_bakes = 1 in
Loop.n_times ballot_bakes (fun _ ->
Tezos_client.Keyed.bake state baker_0 "Baking the promotion vote ballots")
>>= fun () ->
Counter_log.add level_counter "bake-the-ballots" ballot_bakes ;
Tezos_client.successful_client_cmd
state
~client:(client 0)
["list"; "understood"; "protocols"]
>>= fun client_protocols_result ->
Interactive_test.Pauser.generic
state
EF.
[ af "Final ballot(s) are baked in.";
af
"The client `%s` understands the following protocols: %s"
Tezos_executable.(
Option.value
~default:(default_binary client_exec)
client_exec.binary)
(String.concat ~sep:", " client_protocols_result#out) ]
>>= fun () ->
Helpers.wait_for
state
~seconds:0.5
~attempts:(1 + protocol.blocks_per_voting_period)
(fun nth ->
let client = baker_0.client in
Running_processes.run_successful_cmdf
state
"curl http://localhost:%d/chains/main/blocks/head/metadata"
client.port
>>= fun curl_res ->
let json_string = curl_res#out |> String.concat ~sep:"\n" in
let json_metadata = Ezjsonm.from_string json_string in
match Jqo.field json_metadata ~k:"next_protocol" with
| `String p when p = winner_hash ->
return (`Done (nth - 1))
| other ->
transfer
state
~client
~amount:1L
~src:baker_0.Tezos_client.Keyed.key_name
~dst:special_baker.Tezos_client.Keyed.key_name
>>= fun _ ->
ksprintf
(Tezos_client.Keyed.bake state baker_0)
"Baker %s bakes %d/%d waiting for next protocol: %S"
client.id
nth
attempts
winner_hash
>>= fun () ->
return
(`Not_done
(sprintf
"Waiting for next_protocol: %S (â %s)"
winner_hash
Ezjsonm.(to_string (wrap other)))))
>>= fun extra_bakes_waiting_for_next_protocol ->
Counter_log.add
level_counter
"wait-for-next-protocol"
extra_bakes_waiting_for_next_protocol ;
check_understood_protocols
state
~client:winner_client
~chain:"main"
~protocol_hash:winner_hash
~expect_clueless_client:clueless_winner
>>= (function
| `Expected_misunderstanding ->
Console.say
state
EF.(
wf "As expected, the client does not know about %s" winner_hash)
| `Failure_to_understand ->
failf "The winner-client does not know about `%s`" winner_hash
| `Proper_understanding -> (
Console.say state EF.(wf "The client knows about %s" winner_hash)
>>= fun () ->
(* This actually depends on the protocol upgrade. *)
Asynchronous_result.bind_on_result
(Tezos_client.successful_client_cmd
state
~client:winner_client
["upgrade"; "baking"; "state"])
~f:(function
| Ok _ ->
return ()
| Error _ ->
Console.say
state
EF.(
desc
(shout "Warning")
(wf
"Command `upgrade baking state` failed, but we \
keep going with the baking.")))
>>= fun () ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to bake on the new winning protocol.";
haf
"Please switch to the Baking app and quit (`q`) this \
prompt." ]
~force:true
>>= fun () ->
Console.say state EF.(wf "Sleeping for a couple of secondsâ¦")
>>= fun () -> System.sleep 4.
(* USB thing is often slower than humans hitting `q` *))
>>= fun (_ : unit option) ->
Tezos_client.Keyed.bake
state
winner_baker_0
"First bake on new protocol !!"
>>= fun () ->
Counter_log.incr level_counter "baker-0-bakes-on-new-protocol" ;
Tezos_client.Keyed.bake
state
winner_special_baker
"Second bake on new protocol !!"
>>= fun () ->
Counter_log.incr
level_counter
"special-baker-bakes-on-new-protocol" ;
Tezos_client.rpc
state
~client:winner_client
`Get
~path:"/chains/main/blocks/head/metadata"
>>= fun json_metadata ->
match Jqo.field json_metadata ~k:"protocol" with
| `String p when p = winner_hash ->
return ()
| other ->
failf
"Protocol is not `%s` but `%s`"
winner_hash
Ezjsonm.(to_string (wrap other)) ))
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.
[ haf "End of the Voting test: SUCCESS \\o/";
desc
(af "Estimated level: %d" (Counter_log.sum level_counter))
(markdown_verbatim (Counter_log.to_table_string level_counter)) ]
>>= fun () -> return ()
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure
(fun winner_path
demo_path
node_exec
client_exec
admin_exec
winner_client_exec
size
(`Clueless_winner clueless_winner)
(`Base_port base_port)
(`With_ledger with_ledger)
(`Serialize_proposals serialize_proposals)
protocol
state
->
( state,
Interactive_test.Pauser.run_test
state
~pp_error
(run
state
~serialize_proposals
~winner_path
~clueless_winner
~demo_path
~node_exec
~size
~admin_exec
~base_port
~client_exec
~winner_client_exec
~protocol
?with_ledger) ))
$ Arg.(
pure Filename.dirname
$ required
(pos
0
(some string)
None
(info
[]
~docv:"WINNER-PROTOCOL-PATH"
~doc:
"The protocol to inject and make win the election, e.g. \
`src/proto_004_Pt24m4xi/lib_protocol/src/TEZOS_PROTOCOL`.")))
$ Arg.(
pure Filename.dirname
$ required
(pos
1
(some string)
None
(info
[]
~docv:"LOSER-PROTOCOL-PATH"
~doc:
"The protocol to inject and down-vote, e.g. \
`./src/bin_client/test/proto_test_injection/TEZOS_PROTOCOL` \
(if same as `WINNER-PROTOCOL-PATH` the scenario will \
make them automatically & artificially different).")))
$ Tezos_executable.cli_term `Node "current"
$ Tezos_executable.cli_term `Client "current"
$ Tezos_executable.cli_term `Admin "current"
$ Tezos_executable.cli_term `Client "winner"
$ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network.")))
$ Arg.(
pure (fun b -> `Clueless_winner b)
$ value
(flag
(info
["winning-client-is-clueless"]
~doc:
"Do not fail if the client does not know about ânextâ \
protocol.")))
(*
$ Arg.(
pure (fun p -> `Hash p)
$ value
(opt
(some string)
None
(info
["current-hash"]
~doc:"The hash to advertise as the current protocol.")))
*)
$ Arg.(
pure (fun p -> `Base_port p)
$ value
(opt
int
46_000
(info ["base-port"] ~doc:"Base port number to build upon.")))
$ Arg.(
pure (fun x -> `With_ledger x)
$ value
(opt
(some string)
None
(info
["with-ledger"]
~docv:"ledger://..."
~doc:
"Do the test with a Ledger Nano device as one of the \
bakers/voters.")))
$ Arg.(
pure (fun x -> `Serialize_proposals x)
$ value
(flag
(info
["serialize-proposals"]
~doc:
"Run the proposals one-by-one instead of all together \
(preferred by the Ledger).")))
$ Tezos_protocol.cli_term ()
$ Test_command_line.cli_state ~name:"voting" () )
(let doc = "Sandbox network with a full round of voting." in
let man : Manpage.block list =
[ `S "VOTING TEST";
`P
"This command provides a test which uses a network sandbox to \
perform a full round of protocol vote and upgrade, including \
voting and baking on the test chain with or without a Ledger Nano \
device.";
`P "There are two main test behaviors:";
`P
"* $(b,SIMPLE:) The simple one does as much as possible with any \
dummy protocol candidates and a Tezos code-base which doesn't \
handle them: it tests all the voting periods until baking the \
last block of the currently understood protocol.";
`Noblank;
`P
"To allow the test to succeed in this case, the option \
`--winning-client-is-clueless` is required; it is meant to signal \
that the âwinnerâ `tezos-client` executable (from the \
`--winner-client-binary` option) is expected to not understand \
the winning protocol.";
`Noblank;
`P
"This is the version running in Gitlab-CI, see `bin_flextesa/dune`.";
`P
"* $(b,FULL:) Without the `--winning-client-is-clueless` option, \
the test will try to bake on the test chain as well as after the \
protocol switch (with the winner-client). This requires the \
winning protocol to be a working one and, of course, the \
winning-client to understand it.";
`P
"The test can run fully automated unless one uses the \
`\"--with-ledger=ledger://...\"` option in which case some steps \
have to be interactive. In this case, the option \
`--serialize-proposals` is recommended, because if it is not \
provided, the proposal vote will be a âSign Unverfiedâ \
operation." ]
in
info ~doc ~man "voting")
src/bin_sandbox/command_voting.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Counter_log.
End Counter_log.
Definition ledger_prompt_notice {A B C : Type} (state : A) (ef : B) : C :=
op_startypeminuserrorstar state op_startypeminuserrorstar.
Definition setup_baking_ledger {A B C D : Type}
(state : A) (uri : B) (client : C) : D :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar true)
(fun function_parameter =>
let 'tt := function_parameter in
let key_name := "ledgered" % string in
let baker := op_startypeminuserrorstar client key_name uri in
op_startypeminuserrorstar
(ledger_prompt_notice state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state baker)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(ledger_prompt_notice state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "setup" % string
(cons "ledger" % string
(cons "to" % string
(cons "bake" % string
(cons "for" % string
(cons key_name
(cons "--main-hwm" % string
(cons "0" % string
(cons "--test-hwm" % string
(cons "0" % string [])))))))))))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar baker))))).
Definition failf {A B : Type} (fmt : A) : B :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant) fmt.
Definition transfer {A B C D : Type}
(state : A) (client : B) (src : string) (dst : string) (amount : C) : D :=
op_startypeminuserrorstar state client
(cons "--wait" % string
(cons "none" % string
(cons "transfer" % string
(cons (op_startypeminuserrorstar "%Ld" % string amount)
(cons "from" % string
(cons src
(cons "to" % string
(cons dst
(cons "--fee" % string
(cons "0.05" % string
(cons "--burn-cap" % string (cons "0.3" % string [])))))))))))).
Definition register {A B C : Type} (state : A) (client : B) (dst : string)
: C :=
op_startypeminuserrorstar state client
(cons "--wait" % string
(cons "none" % string
(cons "register" % string
(cons "key" % string
(cons dst
(cons "as" % string
(cons "delegate" % string
(cons "--fee" % string (cons "0.05" % string []))))))))).
Definition bake_until_voting_period {A B C D E F : Type}
(keep_alive_delegate : option A) (state : B) (baker : C) (attempts : D)
(period : E) : F :=
let client := Tezos_client.Keyed.client baker in
let period_name := op_startypeminuserrorstar period in
op_startypeminuserrorstar state attempts
(* ❌ Float constant 0.5 is approximated by the integer 0 *)
0
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/blocks/head/votes/current_period_kind" % string)
(fun function_parameter =>
match function_parameter with
| String p =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| _ =>
op_startypeminuserrorstar
(op_startypeminuserrorstar keep_alive_delegate
(fun dst => register state client dst))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar state baker)
"Baker %s bakes %d/%d waiting for %S voting period" % string
(id client) nth attempts period_name)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
end)).
Definition check_understood_protocols {A B C D : Type}
(state : A) (chain : string) (client : B) (protocol_hash : C)
(expect_clueless_client : bool) : D :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "--chain" % string
(cons chain
(cons "list" % string
(cons "understood" % string (cons "protocols" % string []))))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok client_protocols_result =>
match
Stdlib.List.find
(* ❌ Sending method message is not handled *)
send
(* ❌ expected an argument *)
expected_argument
(fun prefix => op_startypeminuserrorstar protocol_hash prefix) with
| _ =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| _ =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| _ =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end
| Stdlib.Error (Client_command_error _) =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| Stdlib.Error e => op_startypeminuserrorstar e
end).
Definition run {A B C D E F G : Type}
(state : A) (winner_path : string) (demo_path : string) (protocol : B)
(node_exec : C) (client_exec : C) (clueless_winner : bool) (admin_exec : C)
(winner_client_exec : C) (size : D) (base_port : E)
(serialize_proposals : bool) (with_ledger : option F)
(function_parameter : unit) : G :=
let 'tt := function_parameter in
let default_attempts := 50 in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(* ❌ Variants not supported *)
variant
(cons node_exec
(cons client_exec (cons admin_exec (cons winner_client_exec []))))
(cons winner_path (cons demo_path [])))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let '(protocol, baker_0_account, baker_0_balance) :=
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar protocol size base_port state
node_exec client_exec)
(fun function_parameter =>
let '(nodes, protocol) := function_parameter in
let make_admin := op_startypeminuserrorstar admin_exec in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let client {H I : Type} (n : H) : I :=
op_startypeminuserrorstar client_exec
(op_startypeminuserrorstar nodes n) in
let baker_0 :=
op_startypeminuserrorstar (client 0) "baker-0" % string
(op_startypeminuserrorstar baker_0_account) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0)
(fun function_parameter =>
let '_ := function_parameter in
let level_counter := op_startypeminuserrorstar tt in
let first_bakes := 5 in
op_startypeminuserrorstar
(op_startypeminuserrorstar first_bakes
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0)
"initial-bake %d" % string nth))
(fun function_parameter =>
let 'tt := function_parameter in
let initial_level := Z.add first_bakes 1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar level_counter
"initial_level" % string initial_level in
op_startypeminuserrorstar
match with_ledger with
| None =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let account :=
op_startypeminuserrorstar
"special-baker" % string in
let baker :=
op_startypeminuserrorstar (client 0)
(op_startypeminuserrorstar account)
(op_startypeminuserrorstar account) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar baker))
| Some uri =>
setup_baking_ledger state uri (client 0)
end
(fun special_baker =>
let winner_client := op_startypeminuserrorstar
in
let winner_baker_0 :=
op_startypeminuserrorstar in
let winner_special_baker :=
op_startypeminuserrorstar in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
op_startypeminuserrorstar
(transfer state (client 0)
"baker-0" % string
(Tezos_client.Keyed.key_name
special_baker)
(Int64.div baker_0_balance
(* ❌ Constant of type int64 is converted to int *)
2000000))
(fun res =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let after_transfer_bakes := 2 in
op_startypeminuserrorstar
(op_startypeminuserrorstar
after_transfer_bakes
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker_0)
"after-transfer-bake %d" %
string nth))
(fun function_parameter =>
let 'tt := function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
level_counter
"after-transfer-bakes" %
string
after_transfer_bakes in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8 nodes
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let '_ :=
function_parameter
in
ledger_prompt_notice
state
op_startypeminuserrorstar))
(fun function_parameter
=>
let '_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state (client 0)
(cons
"--wait" %
string
(cons
"none" %
string
(cons
"register" %
string
(cons
"key" %
string
(cons
(Tezos_client.Keyed.key_name
special_baker)
(cons
"as" %
string
(cons
"delegate"
%
string
(cons
"--fee"
%
string
(cons
"0.5"
%
string
[]))))))))))
(fun
function_parameter
=>
let '_ :=
function_parameter
in
let
activation_bakes :=
op_startypeminuserrorstar
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
activation_bakes
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0)
"Baking after new delegate registered: %d/%d"
%
string
nth
activation_bakes)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
0)
(cons
"rpc"
%
string
(cons
"get"
%
string
(cons
"/chains/main/blocks/head/helpers/baking_rights"
%
string
[]))))
(fun
res
=>
op_startypeminuserrorstar
state
op_startypeminuserrorstar))))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
level_counter
"activation-bakes"
% string
activation_bakes
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
special_baker
"Baked by Special Baker™"
% string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
level_counter
"special-baker-first-bake"
%
string
in
let
attempts :=
op_startypeminuserrorstar
in
op_startypeminuserrorstar
(bake_until_voting_period
(Some
(key_name
baker_0))
state
special_baker
attempts
(* ❌ Variants not supported *)
variant)
(fun
extra_bakes_waiting_for_proposal_period
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _
:=
op_startypeminuserrorstar
level_counter
"wait-for-proposal-period"
%
string
extra_bakes_waiting_for_proposal_period
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
admin_0 :=
op_startypeminuserrorstar
admin_exec
(client
0)
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
admin_0
state
(cons
"list"
%
string
(cons
"protocols"
%
string
[])))
(fun
res
=>
let
default_protocols :=
(* ❌ Sending method message is not handled *)
send
in
let
make_and_inject_protocol
{H
I
:
Type}
(op_staroptstar
:
option
bool)
: H
->
string
->
I :=
let
make_different :=
match
op_staroptstar
with
|
Some
op_starsthstar
=>
op_starsthstar
|
None
=>
false
end
in
fun
name
=>
fun
path
=>
let
tmpdir :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
state)
(op_startypeminuserrorstar
"protocol-%s"
%
string
name)
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
"cp -L -R %s %s"
%
string
(Filename.quote
path)
(Filename.quote
tmpdir))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(if
make_different
then
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
"echo '(* Protocol %s *)' >> %s/main.mli"
%
string
name
(Filename.quote
tmpdir))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
tt)
else
op_startypeminuserrorstar
tt)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
admin_0
state
tmpdir)
(fun
function_parameter
=>
let
'(res,
hash) :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
hash)))))
in
op_startypeminuserrorstar
(make_and_inject_protocol
None
"winner"
%
string
winner_path)
(fun
winner_hash
=>
op_startypeminuserrorstar
(make_and_inject_protocol
(Some
(equiv_decb
winner_path
demo_path))
"demo"
%
string
demo_path)
(fun
demo_hash
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
admin_0
state
(cons
"list"
%
string
(cons
"protocols"
%
string
[])))
(fun
res
=>
let
after_injections_protocols :=
(* ❌ Sending method message is not handled *)
send
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar
true))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
let
submit_proposals
{H
I
:
Type}
(baker
:
H)
(props
:
list
string)
: I :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
ledger_prompt_notice
state
op_startypeminuserrorstar))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(Tezos_client.Keyed.client
baker)
(OCaml.Stdlib.app
(cons
"submit"
%
string
(cons
"proposals"
%
string
(cons
"for"
%
string
(cons
(key_name
baker)
[]))))
props))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
tt))
in
let
to_submit_first :=
cons
winner_hash
(cons
demo_hash
[])
in
op_startypeminuserrorstar
match
serialize_proposals
with
|
false
=>
submit_proposals
special_baker
to_submit_first
|
true
=>
op_startypeminuserrorstar
to_submit_first
(fun
one
=>
submit_proposals
special_baker
(cons
one
[]))
end
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
baker_0)
(cons
"submit"
%
string
(cons
"proposals"
%
string
(cons
"for"
%
string
(cons
(key_name
baker_0)
(cons
winner_hash
[]))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(bake_until_voting_period
(Some
(key_name
special_baker))
state
baker_0
(blocks_per_voting_period
protocol)
(* ❌ Variants not supported *)
variant)
(fun
extra_bakes_waiting_for_testing_vote_period
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"wait-for-testing-vote-period"
%
string
extra_bakes_waiting_for_testing_vote_period
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 2. is approximated by the integer 2 *)
2
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
1)
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/votes/current_proposal"
%
string)
(fun
current_proposal_json
=>
if
nequiv_decb
current_proposal_json
(* ❌ Variants not supported *)
variant
then
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
else
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
baker_0)
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(key_name
baker_0)
(cons
winner_hash
(cons
"yay"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
ledger_prompt_notice
state
op_startypeminuserrorstar))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
special_baker)
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(key_name
special_baker)
(cons
winner_hash
(cons
"yay"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(bake_until_voting_period
(Some
(key_name
special_baker))
state
baker_0
(Z.add
1
(blocks_per_voting_period
protocol))
(* ❌ Variants not supported *)
variant)
(fun
extra_bakes_waiting_for_testing_period
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"wait-for-testing-period"
%
string
extra_bakes_waiting_for_testing_period
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(check_understood_protocols
state
"main"
%
string
winner_client
winner_hash
clueless_winner)
(fun
function_parameter
=>
match
function_parameter
with
|
Proper_understanding
=>
let
chain :=
"test"
%
string
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar
true))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
let
testing_bakes :=
5
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
testing_bakes
(fun
ith
=>
let
baker :=
if
equiv_decb
(Z.modulo
ith
2)
0
then
winner_baker_0
else
winner_special_baker
in
op_startypeminuserrorstar
chain
state
baker
(op_startypeminuserrorstar
"Baking on the test chain [%d/%d]"
%
string
(Z.add
ith
1)
testing_bakes)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
chain
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
tt))))
|
Expected_misunderstanding
=>
op_startypeminuserrorstar
state
op_startypeminuserrorstar
|
Failure_to_understand
=>
failf
"Winner-Client cannot bake on test chain!"
%
string
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 0.3 is approximated by the integer 0 *)
0
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
1)
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/metadata"
%
string)
(fun
metadata_json
=>
(* ❌ Try-with are not handled *)
try
match
OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar
metadata_json
"test_chain_status"
%
string)
(op_startypeminuserrorstar
"protocol"
%
string)
with
|
String
s
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
other
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(bake_until_voting_period
(Some
(key_name
special_baker))
state
baker_0
(Z.add
1
(blocks_per_voting_period
protocol))
(* ❌ Variants not supported *)
variant)
(fun
extra_bakes_waiting_for_promotion_period
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"wait-for-promotion-period"
%
string
extra_bakes_waiting_for_promotion_period
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
baker_0)
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(key_name
baker_0)
(cons
winner_hash
(cons
"yay"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar
true)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
ledger_prompt_notice
state
op_startypeminuserrorstar)))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
special_baker)
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(key_name
special_baker)
(cons
winner_hash
(cons
"yay"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
ballot_bakes :=
1
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
ballot_bakes
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
baker_0
"Baking the promotion vote ballots"
%
string))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"bake-the-ballots"
%
string
ballot_bakes
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
0)
(cons
"list"
%
string
(cons
"understood"
%
string
(cons
"protocols"
%
string
[]))))
(fun
client_protocols_result
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(* ❌ Float constant 0.5 is approximated by the integer 0 *)
0
(Z.add
1
(blocks_per_voting_period
protocol))
(fun
nth
=>
let
client :=
client
baker_0
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
"curl http://localhost:%d/chains/main/blocks/head/metadata"
%
string
(port
client))
(fun
curl_res
=>
let
json_string :=
OCaml.Stdlib.reverse_apply
(* ❌ Sending method message is not handled *)
send
(Stdlib.String.concat
(* ❌ expected an argument *)
expected_argument
(* ❌ expected an argument *)
expected_argument
"
"
%
string)
in
let
json_metadata :=
op_startypeminuserrorstar
json_string
in
match
op_startypeminuserrorstar
json_metadata
"next_protocol"
%
string
with
|
String
p
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
other
=>
op_startypeminuserrorstar
(transfer
state
client
(Tezos_client.Keyed.key_name
baker_0)
(Tezos_client.Keyed.key_name
special_baker)
(* ❌ Constant of type int64 is converted to int *)
1)
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0)
"Baker %s bakes %d/%d waiting for next protocol: %S"
%
string
(id
client)
nth
attempts
winner_hash)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
end)))
(fun
extra_bakes_waiting_for_next_protocol
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"wait-for-next-protocol"
%
string
extra_bakes_waiting_for_next_protocol
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(check_understood_protocols
state
"main"
%
string
winner_client
winner_hash
clueless_winner)
(fun
function_parameter
=>
match
function_parameter
with
|
Expected_misunderstanding
=>
op_startypeminuserrorstar
state
op_startypeminuserrorstar
|
Failure_to_understand
=>
failf
"The winner-client does not know about `%s`"
%
string
winner_hash
|
Proper_understanding
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
winner_client
(cons
"upgrade"
%
string
(cons
"baking"
%
string
(cons
"state"
%
string
[]))))
(fun
function_parameter
=>
match
function_parameter
with
|
Stdlib.Ok
_
=>
op_startypeminuserrorstar
tt
|
Stdlib.Error
_
=>
op_startypeminuserrorstar
state
op_startypeminuserrorstar
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar
true)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(* ❌ Float constant 4. is approximated by the integer 4 *)
4))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
winner_baker_0
"First bake on new protocol !!"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"baker-0-bakes-on-new-protocol"
%
string
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
winner_special_baker
"Second bake on new protocol !!"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"special-baker-bakes-on-new-protocol"
%
string
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
winner_client
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/metadata"
%
string)
(fun
json_metadata
=>
match
op_startypeminuserrorstar
json_metadata
"protocol"
%
string
with
|
String
p
=>
op_startypeminuserrorstar
tt
|
other
=>
failf
"Protocol is not `%s` but `%s`"
%
string
winner_hash
op_startypeminuserrorstar
end))))))
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
tt))))))))))))))))))))))))))))))))))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/main.ml 6 errors
open Flextesa
open Internal_pervasives
module Small_utilities = struct
let key_of_name_command () =
let open Cmdliner in
let open Term in
( ( pure (fun n ->
let open Tezos_protocol.Account in
let account = of_name n in
Printf.printf
"%s,%s,%s,%s\n%!"
(name account)
(pubkey account)
(pubkey_hash account)
(private_key account))
$ Arg.(
required
(pos
0
(some string)
None
(info [] ~docv:"NAME" ~doc:"String to generate the data from.")))
),
info
"key-of-name"
~doc:"Make an unencrypted key-pair deterministically from a string."
~man:
[ `P
"`flextesa key-of-name hello-world` generates a key-pair of the \
`unencrypted:..` kind and outputs it as a 4 values separated \
by commas: `name,pub-key,pub-key-hash,private-uri` (hence \
compatible with the `--add-bootstrap-account` option of some \
of the test scenarios)." ] )
let netstat_ports ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure (fun state ->
( state,
fun () ->
Test_scenario.Network.netstat_listening_ports state
>>= fun ports ->
let to_display =
List.map ports ~f:(fun (p, _) -> p)
|> List.sort ~compare:Int.compare
in
Console.sayf
state
Fmt.(
hvbox ~indent:2 (fun ppf () ->
box words ppf "Netstat listening ports:" ;
sp ppf () ;
box
(list
~sep:(fun ppf () -> string ppf "," ; sp ppf ())
(fun ppf p -> fmt "%d" ppf p))
ppf
to_display)) ))
$ Test_command_line.cli_state
~disable_interactivity:true
~name:"netstat-ports"
() )
(info
"netstat-listening-ports"
~doc:"Like `netstat -nut | awk something-something` but glorified.")
let all ~pp_error () = [key_of_name_command (); netstat_ports ~pp_error ()]
end
let () =
let open Cmdliner in
let help = Term.(ret (pure (`Help (`Auto, None))), info "help") in
let pp_error fmt = function
| `Scenario_error s ->
Format.fprintf fmt "%s" s
| #Test_scenario.Inconsistency_error.t as e ->
Format.fprintf fmt "%a" Test_scenario.Inconsistency_error.pp e
| #Process_result.Error.t as e ->
Format.fprintf fmt "%a" Process_result.Error.pp e
| #System_error.t as e ->
Format.fprintf fmt "%a" System_error.pp e
| `Client_command_error _ as e ->
Tezos_client.Command_error.pp fmt e
| `Admin_command_error _ as e ->
Tezos_admin_client.Command_error.pp fmt e
| `Waiting_for (msg, `Time_out) ->
Format.fprintf fmt "WAITING-FOR â%sâ: Time-out" msg
| `Precheck_failure _ as p ->
Helpers.System_dependencies.Error.pp fmt p
| `Die _ ->
()
in
Term.exit
@@ Term.eval_choice
(help : unit Term.t * _)
( Small_utilities.all ~pp_error ()
@ [ Command_daemons_protocol_change.cmd () ~pp_error;
Command_voting.cmd () ~pp_error;
Command_accusations.cmd () ~pp_error;
Command_prevalidation.cmd () ~pp_error;
Command_ledger_baking.cmd () ~pp_error;
Command_ledger_wallet.cmd () ~pp_error;
Flextesa.Interactive_mini_network.cmd ~pp_error () ] )
src/bin_sandbox/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Small_utilities.
Definition key_of_name_command {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
Definition netstat_ports {A B : Type}
(pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
Definition all {A B : Type} (pp_error : A) (function_parameter : unit)
: list B :=
let 'tt := function_parameter in
cons (key_of_name_command tt) (cons (netstat_ports pp_error tt) []).
End Small_utilities.
src/bin_signer/handler.ml 163 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Signer_logging
let log = lwt_log_notice
module High_watermark = struct
let encoding =
let open Data_encoding in
let raw_hash = conv Blake2B.to_bytes Blake2B.of_bytes_exn bytes in
conv
(List.map (fun (chain_id, marks) ->
(Chain_id.to_b58check chain_id, marks)))
(List.map (fun (chain_id, marks) ->
(Chain_id.of_b58check_exn chain_id, marks)))
@@ assoc
@@ conv
(List.map (fun (pkh, mark) ->
(Signature.Public_key_hash.to_b58check pkh, mark)))
(List.map (fun (pkh, mark) ->
(Signature.Public_key_hash.of_b58check_exn pkh, mark)))
@@ assoc
@@ obj3
(req "level" int32)
(req "hash" raw_hash)
(opt "signature" Signature.encoding)
let mark_if_block_or_endorsement (cctxt : #Client_context.wallet) pkh bytes
sign =
let mark art name get_level =
let file = name ^ "_high_watermark" in
cctxt#with_lock
@@ fun () ->
cctxt#load file ~default:[] encoding
>>=? fun all ->
if Bytes.length bytes < 9 then
failwith "byte sequence too short to be %s %s" art name
else
let hash = Blake2B.hash_bytes [bytes] in
let chain_id = Chain_id.of_bytes_exn (Bytes.sub bytes 1 4) in
let level = get_level () in
( match List.assoc_opt chain_id all with
| None ->
return_none
| Some marks -> (
match List.assoc_opt pkh marks with
| None ->
return_none
| Some (previous_level, _, None) ->
if previous_level >= level then
failwith
"%s level %ld not above high watermark %ld"
name
level
previous_level
else return_none
| Some (previous_level, previous_hash, Some signature) ->
if previous_level > level then
failwith
"%s level %ld below high watermark %ld"
name
level
previous_level
else if previous_level = level then
if previous_hash <> hash then
failwith
"%s level %ld already signed with different data"
name
level
else return_some signature
else return_none ) )
>>=? function
| Some signature ->
return signature
| None ->
sign bytes
>>=? fun signature ->
let rec update = function
| [] ->
[(chain_id, [(pkh, (level, hash, Some signature))])]
| (e_chain_id, marks) :: rest ->
if chain_id = e_chain_id then
let marks =
(pkh, (level, hash, Some signature))
:: List.filter (fun (pkh', _) -> pkh <> pkh') marks
in
(e_chain_id, marks) :: rest
else (e_chain_id, marks) :: update rest
in
cctxt#write file (update all) encoding
>>=? fun () -> return signature
in
if Bytes.length bytes > 0 && TzEndian.get_uint8 bytes 0 = 0x01 then
mark "a" "block" (fun () -> TzEndian.get_int32 bytes 5)
else if Bytes.length bytes > 0 && TzEndian.get_uint8 bytes 0 = 0x02 then
mark "an" "endorsement" (fun () ->
TzEndian.get_int32 bytes (Bytes.length bytes - 4))
else sign bytes
end
module Authorized_key = Client_aliases.Alias (struct
include Signature.Public_key
let name = "authorized_key"
let to_source s = return (to_b58check s)
let of_source t = Lwt.return (of_b58check t)
end)
let check_magic_byte magic_bytes data =
match magic_bytes with
| None ->
return_unit
| Some magic_bytes ->
let byte = TzEndian.get_uint8 data 0 in
if Bytes.length data > 1 && List.mem byte magic_bytes then return_unit
else failwith "magic byte 0x%02X not allowed" byte
let check_authorization cctxt pkh data require_auth signature =
match (require_auth, signature) with
| (false, _) ->
return_unit
| (true, None) ->
failwith "missing authentication signature field"
| (true, Some signature) ->
let to_sign = Signer_messages.Sign.Request.to_sign ~pkh ~data in
Authorized_key.load cctxt
>>=? fun keys ->
if
List.fold_left
(fun acc (_, key) -> acc || Signature.check key signature to_sign)
false
keys
then return_unit
else failwith "invalid authentication signature"
let sign (cctxt : #Client_context.wallet)
Signer_messages.Sign.Request.{pkh; data; signature} ?magic_bytes
~check_high_watermark ~require_auth =
log
Tag.DSL.(
fun f ->
f "Request for signing %d bytes of data for key %a, magic byte = %02X"
-% t event "request_for_signing"
-% s num_bytes (Bytes.length data)
-% a Signature.Public_key_hash.Logging.tag pkh
-% s magic_byte (TzEndian.get_uint8 data 0))
>>= fun () ->
check_magic_byte magic_bytes data
>>=? fun () ->
check_authorization cctxt pkh data require_auth signature
>>=? fun () ->
Client_keys.get_key cctxt pkh
>>=? fun (name, _pkh, sk_uri) ->
log
Tag.DSL.(
fun f ->
f "Signing data for key %s"
-% t event "signing_data"
-% s Client_keys.Logging.tag name)
>>= fun () ->
let sign = Client_keys.sign cctxt sk_uri in
if check_high_watermark then
High_watermark.mark_if_block_or_endorsement cctxt pkh data sign
else sign data
let deterministic_nonce (cctxt : #Client_context.wallet)
Signer_messages.Deterministic_nonce.Request.{pkh; data; signature}
~require_auth =
log
Tag.DSL.(
fun f ->
f "Request for creating a nonce from %d input bytes for key %a"
-% t event "request_for_deterministic_nonce"
-% s num_bytes (Bytes.length data)
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () ->
check_authorization cctxt pkh data require_auth signature
>>=? fun () ->
Client_keys.get_key cctxt pkh
>>=? fun (name, _pkh, sk_uri) ->
log
Tag.DSL.(
fun f ->
f "Creating nonce for key %s"
-% t event "creating_nonce"
-% s Client_keys.Logging.tag name)
>>= fun () -> Client_keys.deterministic_nonce sk_uri data
let deterministic_nonce_hash (cctxt : #Client_context.wallet)
Signer_messages.Deterministic_nonce_hash.Request.{pkh; data; signature}
~require_auth =
log
Tag.DSL.(
fun f ->
f "Request for creating a nonce hash from %d input bytes for key %a"
-% t event "request_for_deterministic_nonce_hash"
-% s num_bytes (Bytes.length data)
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () ->
check_authorization cctxt pkh data require_auth signature
>>=? fun () ->
Client_keys.get_key cctxt pkh
>>=? fun (name, _pkh, sk_uri) ->
log
Tag.DSL.(
fun f ->
f "Creating nonce hash for key %s"
-% t event "creating_nonce_hash"
-% s Client_keys.Logging.tag name)
>>= fun () -> Client_keys.deterministic_nonce_hash sk_uri data
let supports_deterministic_nonces (cctxt : #Client_context.wallet) pkh =
log
Tag.DSL.(
fun f ->
f
"Request for checking whether the signer supports deterministic \
nonces for key %a"
-% t event "request_for_supports_deterministic_nonces"
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () ->
Client_keys.get_key cctxt pkh
>>=? fun (name, _pkh, sk_uri) ->
log
Tag.DSL.(
fun f ->
f
"Returns true if and only if signer can generate determinstic \
nonces for key %s"
-% t event "supports_deterministic_nonces"
-% s Client_keys.Logging.tag name)
>>= fun () -> Client_keys.supports_deterministic_nonces sk_uri
let public_key (cctxt : #Client_context.wallet) pkh =
log
Tag.DSL.(
fun f ->
f "Request for public key %a"
-% t event "request_for_public_key"
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () ->
Client_keys.list_keys cctxt
>>=? fun all_keys ->
match
List.find_opt
(fun (_, h, _, _) -> Signature.Public_key_hash.equal h pkh)
all_keys
with
| None ->
log
Tag.DSL.(
fun f ->
f "No public key found for hash %a"
-% t event "not_found_public_key"
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () -> Lwt.fail Not_found
| Some (_, _, None, _) ->
log
Tag.DSL.(
fun f ->
f "No public key found for hash %a"
-% t event "not_found_public_key"
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () -> Lwt.fail Not_found
| Some (name, _, Some pk, _) ->
log
Tag.DSL.(
fun f ->
f "Found public key for hash %a (name: %s)"
-% t event "found_public_key"
-% a Signature.Public_key_hash.Logging.tag pkh
-% s Client_keys.Logging.tag name)
>>= fun () -> return pk
src/bin_signer/handler.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Signer_logging.
Definition log {A : Type}
: Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
lwt_log_notice.
Module High_watermark.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(list
(Tezos_base__TzPervasives.Chain_id.t *
(list
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(int32 * Tezos_base__TzPervasives.Blake2B.t *
(option Tezos_base__TzPervasives.Signature.t)))))) :=
let raw_hash := conv Blake2B.to_bytes Blake2B.of_bytes_exn None bytes in
apply
(let arg :=
conv
(List.map
(fun function_parameter =>
let '(chain_id, marks) := function_parameter in
((Chain_id.to_b58check chain_id), marks)))
(List.map
(fun function_parameter =>
let '(chain_id, marks) := function_parameter in
((Chain_id.of_b58check_exn chain_id), marks))) in
fun eta => arg None eta)
(apply assoc
(apply
(let arg :=
conv
(List.map
(fun function_parameter =>
let '(pkh, mark) := function_parameter in
((Signature.Public_key_hash.to_b58check pkh), mark)))
(List.map
(fun function_parameter =>
let '(pkh, mark) := function_parameter in
((Signature.Public_key_hash.of_b58check_exn pkh), mark))) in
fun eta => arg None eta)
(apply assoc
(obj3 (req None None "level" % string int32)
(req None None "hash" % string raw_hash)
(opt None None "signature" % string Signature.encoding))))).
Definition mark_if_block_or_endorsement {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(bytes : Stdlib.Bytes.t)
(sign :
Stdlib.Bytes.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
let mark (art : string) (name : string) (get_level : unit -> int32)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
let file := String.append name "_high_watermark" % string in
apply
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send file [] encoding)
(fun all =>
if OCaml.Stdlib.lt (String.length string) 9 then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"byte sequence too short to be " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"byte sequence too short to be %s %s" % string) art name
else
let hash := Blake2B.hash_bytes None (cons string []) in
let chain_id := Chain_id.of_bytes_exn (String.sub string 1 4) in
let level := get_level tt in
op_gtgteqquestion
match List.assoc_opt chain_id all with
| None => return_none
| Some marks =>
match List.assoc_opt pkh marks with
| None => return_none
| Some (previous_level, _, None) =>
if OCaml.Stdlib.ge previous_level level then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" level " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" not above high watermark " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))
"%s level %ld not above high watermark %ld" % string)
name level previous_level
else
return_none
| Some (previous_level, previous_hash, Some signature) =>
if OCaml.Stdlib.gt previous_level level then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" level " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" below high watermark " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))
"%s level %ld below high watermark %ld" % string)
name level previous_level
else
if equiv_decb previous_level level then
if nequiv_decb previous_hash hash then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" level " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" already signed with different data" %
string
CamlinternalFormatBasics.End_of_format))))
"%s level %ld already signed with different data"
% string) name level
else
return_some signature
else
return_none
end
end
(fun function_parameter =>
match function_parameter with
| Some signature => _return signature
| None =>
op_gtgteqquestion (sign string)
(fun signature =>
let fix update
(function_parameter :
list
(Tezos_base__TzPervasives.Chain_id.t *
(list
(Tezos_base__TzPervasives.Signature.Public_key_hash.t
*
(int32 * Tezos_base__TzPervasives.Blake2B.t
*
(option
Tezos_base__TzPervasives.Signature.t))))))
: list
(Tezos_base__TzPervasives.Chain_id.t *
(list
(Tezos_base__TzPervasives.Signature.Public_key_hash.t
*
(int32 * Tezos_base__TzPervasives.Blake2B.t
*
(option
Tezos_base__TzPervasives.Signature.t))))) :=
match function_parameter with
| [] =>
cons
(chain_id,
(cons (pkh, (level, hash, (Some signature)))
[])) []
| cons (e_chain_id, marks) rest =>
if equiv_decb chain_id e_chain_id then
let marks :=
cons (pkh, (level, hash, (Some signature)))
(List.filter
(fun function_parameter =>
let '(pkh', _) := function_parameter in
nequiv_decb pkh pkh') marks) in
cons (e_chain_id, marks) rest
else
cons (e_chain_id, marks) (update rest)
end in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send file (update all) encoding)
(fun function_parameter =>
let 'tt := function_parameter in
_return signature))
end))) in
if
andb (OCaml.Stdlib.gt (String.length string) 0)
(equiv_decb (TzEndian.get_uint8 string 0) 1) then
mark "a" % string "block" % string
(fun function_parameter =>
let 'tt := function_parameter in
TzEndian.get_int32 string 5)
else
if
andb (OCaml.Stdlib.gt (String.length string) 0)
(equiv_decb (TzEndian.get_uint8 string 0) 2) then
mark "an" % string "endorsement" % string
(fun function_parameter =>
let 'tt := function_parameter in
TzEndian.get_int32 string (Z.sub (String.length string) 4))
else
sign string.
End High_watermark.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition check_magic_byte (magic_bytes : option (list Z)) (data : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match magic_bytes with
| None => return_unit
| Some magic_bytes =>
let byte := TzEndian.get_uint8 data 0 in
if andb (OCaml.Stdlib.gt (String.length data) 1) (List.mem byte magic_bytes)
then
return_unit
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "magic byte 0x" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_X
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " not allowed" % string
CamlinternalFormatBasics.End_of_format)))
"magic byte 0x%02X not allowed" % string) byte
end.
Definition check_authorization {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(data : Stdlib.Bytes.t) (require_auth : bool)
(signature : option Tezos_base__TzPervasives.Signature.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match (require_auth, signature) with
| (false, _) => return_unit
| (true, None) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"missing authentication signature field" % string
CamlinternalFormatBasics.End_of_format)
"missing authentication signature field" % string)
| (true, Some signature) =>
let to_sign := Signer_messages.Sign.Request.to_sign pkh data in
op_gtgteqquestion (Authorized_key.load cctxt)
(fun keys =>
if
List.fold_left
(fun acc =>
fun function_parameter =>
let '(_, key) := function_parameter in
orb acc (Signature.check None key signature to_sign)) false keys
then
return_unit
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"invalid authentication signature" % string
CamlinternalFormatBasics.End_of_format)
"invalid authentication signature" % string))
end.
Definition sign {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
(function_parameter : Tezos_signer_services.Signer_messages.Sign.Request.t)
: (option (list Z)) ->
bool ->
bool ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.t) :=
let '{| pkh := pkh; data := data; signature := signature |} :=
function_parameter in
fun magic_bytes =>
fun check_high_watermark =>
fun require_auth =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for signing " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" bytes of data for key " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", magic byte = " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_X
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))))
"Request for signing %d bytes of data for key %a, magic byte = %02X"
% string)) (t event "request_for_signing" % string))
(s num_bytes (String.length data)))
(a Signature.Public_key_hash.Logging.tag pkh))
(s magic_byte (TzEndian.get_uint8 data 0))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (check_magic_byte magic_bytes data)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_authorization cctxt pkh data require_auth signature)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt pkh)
(fun function_parameter =>
let '(name, _pkh, sk_uri) := function_parameter in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Signing data for key " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Signing data for key %s" % string))
(t event "signing_data" % string))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
let sign := Client_keys.sign cctxt None sk_uri in
if check_high_watermark then
High_watermark.mark_if_block_or_endorsement cctxt
pkh data sign
else
sign data))))).
Definition deterministic_nonce {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
(function_parameter :
Tezos_signer_services.Signer_messages.Deterministic_nonce.Request.t)
: bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
let '{| pkh := pkh; data := data; signature := signature |} :=
function_parameter in
fun require_auth =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for creating a nonce from " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" input bytes for key " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Request for creating a nonce from %d input bytes for key %a"
% string))
(t event "request_for_deterministic_nonce" % string))
(s num_bytes (String.length data)))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_authorization cctxt pkh data require_auth signature)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt pkh)
(fun function_parameter =>
let '(name, _pkh, sk_uri) := function_parameter in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Creating nonce for key " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Creating nonce for key %s" % string))
(t event "creating_nonce" % string))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
Client_keys.deterministic_nonce sk_uri data)))).
Definition deterministic_nonce_hash {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
(function_parameter :
Tezos_signer_services.Signer_messages.Deterministic_nonce_hash.Request.t)
: bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
let '{| pkh := pkh; data := data; signature := signature |} :=
function_parameter in
fun require_auth =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for creating a nonce hash from " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" input bytes for key " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Request for creating a nonce hash from %d input bytes for key %a"
% string))
(t event "request_for_deterministic_nonce_hash" % string))
(s num_bytes (String.length data)))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_authorization cctxt pkh data require_auth signature)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt pkh)
(fun function_parameter =>
let '(name, _pkh, sk_uri) := function_parameter in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Creating nonce hash for key " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Creating nonce hash for key %s" % string))
(t event "creating_nonce_hash" % string))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
Client_keys.deterministic_nonce_hash sk_uri data)))).
Definition supports_deterministic_nonces {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Tezos_crypto__Signature.Public_key_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for checking whether the signer supports deterministic nonces for key "
% string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Request for checking whether the signer supports deterministic nonces for key %a"
% string))
(t event "request_for_supports_deterministic_nonces" % string))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt pkh)
(fun function_parameter =>
let '(name, _pkh, sk_uri) := function_parameter in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Returns true if and only if signer can generate determinstic nonces for key "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Returns true if and only if signer can generate determinstic nonces for key %s"
% string))
(t event "supports_deterministic_nonces" % string))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
Client_keys.supports_deterministic_nonces sk_uri))).
Definition public_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Tezos_crypto__Signature.Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.public_key) :=
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for public key " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Request for public key %a" % string))
(t event "request_for_public_key" % string))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.list_keys cctxt)
(fun all_keys =>
match
List.find_opt
(fun function_parameter =>
let '(_, h, _, _) := function_parameter in
Signature.Public_key_hash.equal h pkh) all_keys with
| None =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No public key found for hash " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"No public key found for hash %a" % string))
(t event "not_found_public_key" % string))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.fail OCaml.Not_found)
| Some (_, _, None, _) =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No public key found for hash " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"No public key found for hash %a" % string))
(t event "not_found_public_key" % string))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.fail OCaml.Not_found)
| Some (name, _, Some pk, _) =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Found public key for hash " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (name: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))
"Found public key for hash %a (name: %s)" % string))
(t event "found_public_key" % string))
(a Signature.Public_key_hash.Logging.tag pkh))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
_return pk)
end)).
src/bin_signer/http_daemon.ml 43 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let log = Signer_logging.lwt_log_notice
open Signer_logging
let run (cctxt : #Client_context.wallet) ~hosts ?magic_bytes
~check_high_watermark ~require_auth mode =
let dir = RPC_directory.empty in
let dir =
RPC_directory.register1 dir Signer_services.sign (fun pkh signature data ->
Handler.sign
cctxt
{pkh; data; signature}
?magic_bytes
~check_high_watermark
~require_auth)
in
let dir =
RPC_directory.register1 dir Signer_services.public_key (fun pkh () () ->
Handler.public_key cctxt pkh)
in
let dir =
RPC_directory.register0 dir Signer_services.authorized_keys (fun () () ->
if require_auth then
Handler.Authorized_key.load cctxt
>>=? fun keys ->
return_some
(keys |> List.split |> snd |> List.map Signature.Public_key.hash)
else return_none)
in
Lwt.catch
(fun () ->
List.map
(fun host ->
let host = Ipaddr.V6.to_string host in
log
Tag.DSL.(
fun f ->
f "Listening on address %s"
-% t event "signer_listening" -% s host_name host)
>>= fun () ->
RPC_server.launch
~host
mode
dir
~media_types:Media_type.all_media_types
>>= fun _server -> fst (Lwt.wait ()))
hosts
|> Lwt.choose)
(function
| Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
failwith "Port already in use."
| exn ->
Lwt.return (error_exn exn))
let run_https (cctxt : #Client_context.wallet) ~host ~port ~cert ~key
?magic_bytes ~check_high_watermark ~require_auth =
Lwt_utils_unix.getaddrinfo
~passive:true
~node:host
~service:(string_of_int port)
>>= function
| [] ->
failwith "Cannot resolve listening address: %S" host
| points ->
let hosts = fst (List.split points) in
log
Tag.DSL.(
fun f ->
f "Accepting HTTPS requests on port %d"
-% t event "accepting_https_requests"
-% s port_number port)
>>= fun () ->
let mode : Conduit_lwt_unix.server =
`TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
in
run
(cctxt : #Client_context.wallet)
~hosts
?magic_bytes
~check_high_watermark
~require_auth
mode
let run_http (cctxt : #Client_context.wallet) ~host ~port ?magic_bytes
~check_high_watermark ~require_auth =
Lwt_utils_unix.getaddrinfo
~passive:true
~node:host
~service:(string_of_int port)
>>= function
| [] ->
failwith "Cannot resolve listening address: %S" host
| points ->
let hosts = fst (List.split points) in
log
Tag.DSL.(
fun f ->
f "Accepting HTTP requests on port %d"
-% t event "accepting_http_requests"
-% s port_number port)
>>= fun () ->
let mode : Conduit_lwt_unix.server = `TCP (`Port port) in
run
(cctxt : #Client_context.wallet)
~hosts
?magic_bytes
~check_high_watermark
~require_auth
mode
src/bin_signer/http_daemon.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition log {A : Type}
: Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
Signer_logging.lwt_log_notice.
Import Signer_logging.
Definition run {B C a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (hosts : list Ipaddr.V6.t) (magic_bytes : option (list Z))
(check_high_watermark : bool) (require_auth : bool)
(mode : Conduit_lwt_unix.server)
: Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
let dir := RPC_directory.empty in
let dir :=
RPC_directory.register1 dir Signer_services.sign
(fun pkh =>
fun signature =>
fun data =>
Handler.sign cctxt
{| pkh := pkh; data := data; signature := signature |} magic_bytes
check_high_watermark require_auth) in
let dir :=
RPC_directory.register1 dir Signer_services.public_key
(fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Handler.public_key cctxt pkh) in
let dir :=
RPC_directory.register0 dir Signer_services.authorized_keys
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
if require_auth then
op_gtgteqquestion (Handler.Authorized_key.load cctxt)
(fun keys =>
return_some
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply keys List.split) snd)
(List.map Signature.Public_key.hash)))
else
return_none) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.reverse_apply
(List.map
(fun host =>
let host := Ipaddr.V6.to_string host in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Listening on address " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Listening on address %s" % string))
(t event "signer_listening" % string)) (s host_name host)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(RPC_server.launch (Some host) None Media_type.all_media_types
mode dir) (fun _server => fst (Lwt.wait tt)))) hosts)
Lwt.choose)
(fun function_parameter =>
match function_parameter with
| Unix_error Unix.EADDRINUSE "bind" % string "" % string =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Port already in use." % string
CamlinternalFormatBasics.End_of_format)
"Port already in use." % string)
| exn => Lwt._return (error_exn exn)
end).
Definition run_https {B C a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (host : string) (port : Z) (cert : string) (key : string)
(magic_bytes : option (list Z)) (check_high_watermark : bool)
(require_auth : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
op_gtgteq
(Lwt_utils_unix.getaddrinfo true host (OCaml.Stdlib.string_of_int port))
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve listening address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve listening address: %S" % string) host
| points =>
let hosts := fst (List.split points) in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accepting HTTPS requests on port " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Accepting HTTPS requests on port %d" % string))
(t event "accepting_https_requests" % string))
(s port_number port)))
(fun function_parameter =>
let 'tt := function_parameter in
let mode :=
(* ❌ Variants not supported *)
variant in
run cctxt hosts magic_bytes check_high_watermark require_auth mode)
end).
Definition run_http {B C a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (host : string) (port : Z) (magic_bytes : option (list Z))
(check_high_watermark : bool) (require_auth : bool)
: Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
op_gtgteq
(Lwt_utils_unix.getaddrinfo true host (OCaml.Stdlib.string_of_int port))
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve listening address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve listening address: %S" % string) host
| points =>
let hosts := fst (List.split points) in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accepting HTTP requests on port " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Accepting HTTP requests on port %d" % string))
(t event "accepting_http_requests" % string))
(s port_number port)))
(fun function_parameter =>
let 'tt := function_parameter in
let mode :=
(* ❌ Variants not supported *)
variant in
run cctxt hosts magic_bytes check_high_watermark require_auth mode)
end).
src/bin_signer/main_signer.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "signer.main"
end)
let default_tcp_host =
match Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" with
| None ->
"localhost"
| Some host ->
host
let default_tcp_port =
match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" with
| None ->
"7732"
| Some port ->
port
let default_https_host =
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" with
| None ->
"localhost"
| Some host ->
host
let default_https_port =
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" with
| None ->
"443"
| Some port ->
port
let default_http_host =
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" with
| None ->
"localhost"
| Some host ->
host
let default_http_port =
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" with
| None ->
"6732"
| Some port ->
port
open Clic
let group =
{Clic.name = "signer"; title = "Commands specific to the signing daemon"}
let magic_bytes_arg =
Clic.arg
~doc:"values allowed for the magic bytes, defaults to any"
~short:'M'
~long:"magic-bytes"
~placeholder:"0xHH,0xHH,..."
(Clic.parameter (fun _ s ->
try
return
(List.map
(fun s ->
let b = int_of_string s in
if b < 0 || b > 255 then raise Exit else b)
(String.split ',' s))
with _ ->
failwith
"Bad format for magic bytes, a series of numbers is expected, \
separated by commas."))
let high_watermark_switch =
Clic.switch
~doc:
"high watermark restriction\n\
Stores the highest level signed for blocks and endorsements for each \
address, and forbids to sign a level that is inferior or equal \
afterwards, except for the exact same input data."
~short:'W'
~long:"check-high-watermark"
()
let pidfile_arg =
arg
~doc:"write process id in file"
~short:'P'
~long:"pidfile"
~placeholder:"filename"
(parameter (fun _ s -> return s))
let may_setup_pidfile = function
| None ->
return_unit
| Some pidfile ->
trace (failure "Failed to create the pidfile: %s" pidfile)
@@ Lwt_lock_file.create ~unlink_on_exit:true pidfile
let commands base_dir require_auth : Client_context.full command list =
Tezos_signer_backends_unix.Ledger.commands ()
@ Client_keys_commands.commands None
@ [ command
~group
~desc:"Launch a signer daemon over a TCP socket."
(args5
pidfile_arg
magic_bytes_arg
high_watermark_switch
(default_arg
~doc:"listening address or host name"
~short:'a'
~long:"address"
~placeholder:"host|address"
~default:default_tcp_host
(parameter (fun _ s -> return s)))
(default_arg
~doc:"listening TCP port or service name"
~short:'p'
~long:"port"
~placeholder:"port number"
~default:default_tcp_port
(parameter (fun _ s -> return s))))
(prefixes ["launch"; "socket"; "signer"] @@ stop)
(fun (pidfile, magic_bytes, check_high_watermark, host, port) cctxt ->
may_setup_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_all cctxt
>>=? fun () ->
Socket_daemon.run
cctxt
(Tcp (host, port, [AI_SOCKTYPE SOCK_STREAM]))
?magic_bytes
~check_high_watermark
~require_auth
>>=? fun _ -> return_unit);
command
~group
~desc:"Launch a signer daemon over a local Unix socket."
(args4
pidfile_arg
magic_bytes_arg
high_watermark_switch
(default_arg
~doc:"path to the local socket file"
~short:'s'
~long:"socket"
~placeholder:"path"
~default:(Filename.concat base_dir "socket")
(parameter (fun _ s -> return s))))
(prefixes ["launch"; "local"; "signer"] @@ stop)
(fun (pidfile, magic_bytes, check_high_watermark, path) cctxt ->
may_setup_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_all cctxt
>>=? fun () ->
Socket_daemon.run
cctxt
(Unix path)
?magic_bytes
~check_high_watermark
~require_auth
>>=? fun _ -> return_unit);
command
~group
~desc:"Launch a signer daemon over HTTP."
(args5
pidfile_arg
magic_bytes_arg
high_watermark_switch
(default_arg
~doc:"listening address or host name"
~short:'a'
~long:"address"
~placeholder:"host|address"
~default:default_http_host
(parameter (fun _ s -> return s)))
(default_arg
~doc:"listening HTTP port"
~short:'p'
~long:"port"
~placeholder:"port number"
~default:default_http_port
(parameter (fun _ x ->
try return (int_of_string x)
with Failure _ -> failwith "Invalid port %s" x))))
(prefixes ["launch"; "http"; "signer"] @@ stop)
(fun (pidfile, magic_bytes, check_high_watermark, host, port) cctxt ->
may_setup_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_all cctxt
>>=? fun () ->
Http_daemon.run_http
cctxt
~host
~port
?magic_bytes
~check_high_watermark
~require_auth);
command
~group
~desc:"Launch a signer daemon over HTTPS."
(args5
pidfile_arg
magic_bytes_arg
high_watermark_switch
(default_arg
~doc:"listening address or host name"
~short:'a'
~long:"address"
~placeholder:"host|address"
~default:default_https_host
(parameter (fun _ s -> return s)))
(default_arg
~doc:"listening HTTPS port"
~short:'p'
~long:"port"
~placeholder:"port number"
~default:default_https_port
(parameter (fun _ x ->
try return (int_of_string x)
with Failure _ -> failwith "Invalid port %s" x))))
( prefixes ["launch"; "https"; "signer"]
@@ param
~name:"cert"
~desc:"path to the TLS certificate"
(parameter (fun _ s ->
if not (Sys.file_exists s) then
failwith "No such TLS certificate file %s" s
else return s))
@@ param
~name:"key"
~desc:"path to the TLS key"
(parameter (fun _ s ->
if not (Sys.file_exists s) then
failwith "No such TLS key file %s" s
else return s))
@@ stop )
(fun (pidfile, magic_bytes, check_high_watermark, host, port)
cert
key
cctxt ->
may_setup_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_all cctxt
>>=? fun () ->
Http_daemon.run_https
cctxt
~host
~port
~cert
~key
?magic_bytes
~check_high_watermark
~require_auth);
command
~group
~desc:"Authorize a given public key to perform signing requests."
(args1
(arg
~doc:"an optional name for the key (defaults to the hash)"
~short:'N'
~long:"name"
~placeholder:"name"
(parameter (fun _ s -> return s))))
( prefixes ["add"; "authorized"; "key"]
@@ param
~name:"pk"
~desc:"full public key (Base58 encoded)"
(parameter (fun _ s ->
Lwt.return (Signature.Public_key.of_b58check s)))
@@ stop )
(fun name key cctxt ->
let pkh = Signature.Public_key.hash key in
let name =
match name with
| Some name ->
name
| None ->
Signature.Public_key_hash.to_b58check pkh
in
Handler.Authorized_key.add ~force:false cctxt name key) ]
let home = try Sys.getenv "HOME" with Not_found -> "/root"
let default_base_dir = Filename.concat home ".tezos-signer"
let string_parameter () : (string, _) parameter =
parameter (fun _ x -> return x)
let base_dir_arg () =
arg
~long:"base-dir"
~short:'d'
~placeholder:"path"
~doc:
( "signer data directory\n\
The directory where the Tezos client will store all its data.\n\
By default: '" ^ default_base_dir ^ "'." )
(string_parameter ())
let require_auth_arg () =
switch
~long:"require-authentication"
~short:'A'
~doc:"Require a signature from the caller to sign."
()
let password_filename_arg () =
arg
~long:"password-file"
~short:'f'
~placeholder:"filename"
~doc:"Absolute path of the password file"
(string_parameter ())
let global_options () =
args3 (base_dir_arg ()) (require_auth_arg ()) (password_filename_arg ())
module C = struct
type t = string option * bool * string option
let global_options = global_options
let parse_config_args ctx argv =
Clic.parse_global_options (global_options ()) ctx argv
>>=? fun ((base_dir, require_auth, password_filename), remaining) ->
return
( {
Client_config.default_parsed_config_args with
base_dir;
require_auth;
password_filename;
},
remaining )
let default_chain = Client_config.default_chain
let default_block = Client_config.default_block
let default_base_dir = default_base_dir
let other_registrations = None
let clic_commands ~base_dir ~config_commands:_ ~builtin_commands:_
~other_commands ~require_auth =
commands base_dir require_auth @ other_commands
let logger = Some (RPC_client_unix.full_logger Format.err_formatter)
end
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module C)
~select_commands:(fun _ _ -> return_nil)
src/bin_signer/main_signer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition default_tcp_host : string :=
match Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" % string with
| None => "localhost" % string
| Some host => host
end.
Definition default_tcp_port : string :=
match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" % string with
| None => "7732" % string
| Some port => port
end.
Definition default_https_host : string :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" % string with
| None => "localhost" % string
| Some host => host
end.
Definition default_https_port : string :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" % string with
| None => "443" % string
| Some port => port
end.
Definition default_http_host : string :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" % string with
| None => "localhost" % string
| Some host => host
end.
Definition default_http_port : string :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" % string with
| None => "6732" % string
| Some port => port
end.
Import Clic.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "signer" % string;
Clic.title := "Commands specific to the signing daemon" % string |}.
Definition magic_bytes_arg
: Tezos_base__TzPervasives.Clic.arg (option (list Z))
Tezos_client_base.Client_context.full :=
Clic.arg "values allowed for the magic bytes, defaults to any" % string
(Some "M" % char) "magic-bytes" % string "0xHH,0xHH,..." % string
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(_return
(List.map
(fun s =>
let b := OCaml.Stdlib.int_of_string s in
if orb (OCaml.Stdlib.lt b 0) (OCaml.Stdlib.gt b 255) then
Stdlib.raise Exit
else
b) (String.split "," % char None None s))))).
Definition high_watermark_switch
: Tezos_base__TzPervasives.Clic.arg bool Tezos_client_base.Client_context.full :=
Clic.switch
"high watermark restriction
Stores the highest level signed for blocks and endorsements for each address, and forbids to sign a level that is inferior or equal afterwards, except for the exact same input data."
% string (Some "W" % char) "check-high-watermark" % string tt.
Definition pidfile_arg
: Tezos_base__TzPervasives.Clic.arg (option string)
Tezos_client_base.Client_context.full :=
arg "write process id in file" % string (Some "P" % char) "pidfile" % string
"filename" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)).
Definition may_setup_pidfile (function_parameter : option string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| None => return_unit
| Some pidfile =>
apply
(trace
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to create the pidfile: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Failed to create the pidfile: %s" % string) pidfile))
(Lwt_lock_file.create None (Some true) pidfile)
end.
Definition commands (base_dir : string) (require_auth : bool)
: list
(Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
OCaml.Stdlib.app (Tezos_signer_backends_unix.Ledger.commands tt)
(OCaml.Stdlib.app (Client_keys_commands.commands None)
(cons
(command (Some group)
"Launch a signer daemon over a TCP socket." % string
(args5 pidfile_arg magic_bytes_arg high_watermark_switch
(default_arg "listening address or host name" % string
(Some "a" % char) "address" % string "host|address" % string
default_tcp_host
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)))
(default_arg "listening TCP port or service name" % string
(Some "p" % char) "port" % string "port number" % string
default_tcp_port
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s))))
(apply
(prefixes
(cons "launch" % string
(cons "socket" % string (cons "signer" % string [])))) stop)
(fun function_parameter =>
let '(pidfile, magic_bytes, check_high_watermark, host, port) :=
function_parameter in
fun cctxt =>
op_gtgteqquestion (may_setup_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_all cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Socket_daemon.run cctxt
(Tezos_stdlib_unix.Lwt_utils_unix.Socket.Tcp host port
(cons (Unix.AI_SOCKTYPE Unix.SOCK_STREAM) []))
magic_bytes check_high_watermark require_auth)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))))
(cons
(command (Some group)
"Launch a signer daemon over a local Unix socket." % string
(args4 pidfile_arg magic_bytes_arg high_watermark_switch
(default_arg "path to the local socket file" % string
(Some "s" % char) "socket" % string "path" % string
(Filename.concat base_dir "socket" % string)
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s))))
(apply
(prefixes
(cons "launch" % string
(cons "local" % string (cons "signer" % string [])))) stop)
(fun function_parameter =>
let '(pidfile, magic_bytes, check_high_watermark, path) :=
function_parameter in
fun cctxt =>
op_gtgteqquestion (may_setup_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_all cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Socket_daemon.run cctxt
(Tezos_stdlib_unix.Lwt_utils_unix.Socket.Unix path)
magic_bytes check_high_watermark require_auth)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))))
(cons
(command (Some group) "Launch a signer daemon over HTTP." % string
(args5 pidfile_arg magic_bytes_arg high_watermark_switch
(default_arg "listening address or host name" % string
(Some "a" % char) "address" % string "host|address" % string
default_http_host
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)))
(default_arg "listening HTTP port" % string (Some "p" % char)
"port" % string "port number" % string default_http_port
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
(* ❌ Try-with are not handled *)
try (_return (OCaml.Stdlib.int_of_string x))))))
(apply
(prefixes
(cons "launch" % string
(cons "http" % string (cons "signer" % string [])))) stop)
(fun function_parameter =>
let '(pidfile, magic_bytes, check_high_watermark, host, port) :=
function_parameter in
fun cctxt =>
op_gtgteqquestion (may_setup_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_all cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
Http_daemon.run_http cctxt host port magic_bytes
check_high_watermark require_auth))))
(cons
(command (Some group)
"Launch a signer daemon over HTTPS." % string
(args5 pidfile_arg magic_bytes_arg high_watermark_switch
(default_arg "listening address or host name" % string
(Some "a" % char) "address" % string "host|address" % string
default_https_host
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)))
(default_arg "listening HTTPS port" % string (Some "p" % char)
"port" % string "port number" % string default_https_port
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
(* ❌ Try-with are not handled *)
try (_return (OCaml.Stdlib.int_of_string x))))))
(apply
(prefixes
(cons "launch" % string
(cons "https" % string (cons "signer" % string []))))
(apply
(param "cert" % string
"path to the TLS certificate" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
if negb (Sys.file_exists s) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No such TLS certificate file " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"No such TLS certificate file %s" % string) s
else
_return s)))
(apply
(param "key" % string "path to the TLS key" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
if negb (Sys.file_exists s) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No such TLS key file " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"No such TLS key file %s" % string) s
else
_return s))) stop)))
(fun function_parameter =>
let
'(pidfile, magic_bytes, check_high_watermark, host, port) :=
function_parameter in
fun cert =>
fun key =>
fun cctxt =>
op_gtgteqquestion (may_setup_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_all cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
Http_daemon.run_https cctxt host port cert key
magic_bytes check_high_watermark require_auth))))
(cons
(command (Some group)
"Authorize a given public key to perform signing requests." %
string
(args1
(arg
"an optional name for the key (defaults to the hash)" %
string (Some "N" % char) "name" % string "name" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s))))
(apply
(prefixes
(cons "add" % string
(cons "authorized" % string (cons "key" % string []))))
(apply
(param "pk" % string
"full public key (Base58 encoded)" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
Lwt._return (Signature.Public_key.of_b58check s))))
stop))
(fun name =>
fun key =>
fun cctxt =>
let pkh := Signature.Public_key.hash key in
let name :=
match name with
| Some name => name
| None => Signature.Public_key_hash.to_b58check pkh
end in
Handler.Authorized_key.add false cctxt name key)) [])))))).
Definition home : string :=
(* ❌ Try-with are not handled *)
try (Sys.getenv "HOME" % string).
Definition default_base_dir : string :=
Filename.concat home ".tezos-signer" % string.
Definition string_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter string A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => _return x).
Definition base_dir_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string) A :=
let 'tt := function_parameter in
arg
(String.append
"signer data directory
The directory where the Tezos client will store all its data.
By default: '"
% string (String.append default_base_dir "'." % string))
(Some "d" % char) "base-dir" % string "path" % string (string_parameter tt).
Definition require_auth_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
switch "Require a signature from the caller to sign." % string
(Some "A" % char) "require-authentication" % string tt.
Definition password_filename_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string) A :=
let 'tt := function_parameter in
arg "Absolute path of the password file" % string (Some "f" % char)
"password-file" % string "filename" % string (string_parameter tt).
Definition global_options {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.options
((option string) * bool * (option string)) A :=
let 'tt := function_parameter in
args3 (base_dir_arg tt) (require_auth_arg tt) (password_filename_arg tt).
Module C.
Definition t := (option string) * bool * (option string).
Definition global_options {A : Type}
: unit ->
Tezos_base__TzPervasives.Clic.options
((option string) * bool * (option string)) A := global_options.
Definition parse_config_args {A : Type} (ctx : A) (argv : list string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_base_unix.Client_config.parsed_config_args * (list string))) :=
op_gtgteqquestion (Clic.parse_global_options (global_options tt) ctx argv)
(fun function_parameter =>
let '((base_dir, require_auth, password_filename), remaining) :=
function_parameter in
_return
((* ❌ Record substitution not handled *)
record_substitution, remaining)).
Definition default_chain : variant := Client_config.default_chain.
Definition default_block : variant := Client_config.default_block.
Definition default_base_dir : string := default_base_dir.
Definition other_registrations {A : Type} : option A := None.
Definition clic_commands {A B : Type}
(base_dir : string) (function_parameter : A)
: B ->
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)) ->
bool ->
list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun other_commands =>
fun require_auth =>
OCaml.Stdlib.app (commands base_dir require_auth) other_commands.
Definition logger
: option Tezos_rpc_http_client_unix.RPC_client_unix.logger :=
Some (RPC_client_unix.full_logger Format.err_formatter).
End C.
src/bin_signer/signer_logging.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Internal_event.Legacy_logging.Make_semantic (struct let name = "client.signer" end) let host_name = Tag.def ~doc:"Host name" "host" Format.pp_print_text let service_name = Tag.def ~doc:"Service name" "service" Format.pp_print_text let port_number = Tag.def ~doc:"Port number" "port" Format.pp_print_int let magic_byte = Tag.def ~doc:"Magic byte" "magic_byte" Format.pp_print_int let num_bytes = Tag.def ~doc:"Number of bytes" "num_bytes" Format.pp_print_int let unix_socket_path = Tag.def ~doc:"UNIX socket file path" "unix_socket" Format.pp_print_text
src/bin_signer/signer_logging.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition host_name : Tag.def string :=
Tag.def (Some "Host name" % string) "host" % string Format.pp_print_text.
Definition service_name : Tag.def string :=
Tag.def (Some "Service name" % string) "service" % string Format.pp_print_text.
Definition port_number : Tag.def Z :=
Tag.def (Some "Port number" % string) "port" % string Format.pp_print_int.
Definition magic_byte : Tag.def Z :=
Tag.def (Some "Magic byte" % string) "magic_byte" % string Format.pp_print_int.
Definition num_bytes : Tag.def Z :=
Tag.def (Some "Number of bytes" % string) "num_bytes" % string
Format.pp_print_int.
Definition unix_socket_path : Tag.def string :=
Tag.def (Some "UNIX socket file path" % string) "unix_socket" % string
Format.pp_print_text.
src/bin_signer/socket_daemon.ml 56 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Signer_logging
open Signer_messages
let log = lwt_log_notice
let handle_client ?magic_bytes ~check_high_watermark ~require_auth cctxt fd =
Lwt_utils_unix.Socket.recv fd Request.encoding
>>=? function
| Sign req ->
let encoding = result_encoding Sign.Response.encoding in
Handler.sign cctxt req ?magic_bytes ~check_high_watermark ~require_auth
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Deterministic_nonce req ->
let encoding = result_encoding Deterministic_nonce.Response.encoding in
Handler.deterministic_nonce cctxt req ~require_auth
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Deterministic_nonce_hash req ->
let encoding =
result_encoding Deterministic_nonce_hash.Response.encoding
in
Handler.deterministic_nonce_hash cctxt req ~require_auth
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Supports_deterministic_nonces req ->
let encoding =
result_encoding Supports_deterministic_nonces.Response.encoding
in
Handler.supports_deterministic_nonces cctxt req
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Public_key pkh ->
let encoding = result_encoding Public_key.Response.encoding in
Handler.public_key cctxt pkh
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Authorized_keys ->
let encoding = result_encoding Authorized_keys.Response.encoding in
( if require_auth then
Handler.Authorized_key.load cctxt
>>=? fun keys ->
return
(Authorized_keys.Response.Authorized_keys
(keys |> List.split |> snd |> List.map Signature.Public_key.hash))
else return Authorized_keys.Response.No_authentication )
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
let run (cctxt : #Client_context.wallet) path ?magic_bytes
~check_high_watermark ~require_auth =
let open Lwt_utils_unix.Socket in
( match path with
| Tcp (host, service, _opts) ->
log
Tag.DSL.(
fun f ->
f "Accepting TCP requests on %s:%s"
-% t event "accepting_tcp_requests"
-% s host_name host -% s service_name service)
| Unix path ->
ListLabels.iter
Sys.[sigint; sigterm]
~f:(fun signal ->
Sys.set_signal
signal
(Signal_handle
(fun _ ->
Format.printf "Removing the local socket file and quitting.@." ;
Unix.unlink path ;
exit 0))) ;
log
Tag.DSL.(
fun f ->
f "Accepting UNIX requests on %s"
-% t event "accepting_unix_requests"
-% s unix_socket_path path) )
>>= fun () ->
bind path
>>=? fun fds ->
let rec loop fd =
Lwt_unix.accept fd
>>= fun (cfd, _) ->
Lwt.async (fun () ->
protect
~on_error:(function
| Exn End_of_file :: _ ->
return_unit
| errs ->
Lwt.return_error errs)
(fun () ->
handle_client
?magic_bytes
~check_high_watermark
~require_auth
cctxt
cfd)) ;
loop fd
in
Lwt_list.map_p loop fds >>= return
src/bin_signer/socket_daemon.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Signer_logging.
Import Signer_messages.
Definition log {A : Type}
: Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
lwt_log_notice.
Definition handle_client {B a : Type}
(magic_bytes : option (list Z)) (check_high_watermark : bool)
(require_auth : bool)
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (fd : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (Lwt_utils_unix.Socket.recv fd Request.encoding)
(fun function_parameter =>
match function_parameter with
| Tezos_signer_services.Signer_messages.Request.Sign req =>
let encoding := result_encoding Sign.Response.encoding in
op_gtgteq
(Handler.sign cctxt req magic_bytes check_high_watermark require_auth)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
| Tezos_signer_services.Signer_messages.Request.Deterministic_nonce req =>
let encoding := result_encoding Deterministic_nonce.Response.encoding in
op_gtgteq (Handler.deterministic_nonce cctxt req require_auth)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
|
Tezos_signer_services.Signer_messages.Request.Deterministic_nonce_hash
req =>
let encoding :=
result_encoding Deterministic_nonce_hash.Response.encoding in
op_gtgteq (Handler.deterministic_nonce_hash cctxt req require_auth)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
|
Tezos_signer_services.Signer_messages.Request.Supports_deterministic_nonces
req =>
let encoding :=
result_encoding Supports_deterministic_nonces.Response.encoding in
op_gtgteq (Handler.supports_deterministic_nonces cctxt req)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
| Tezos_signer_services.Signer_messages.Request.Public_key pkh =>
let encoding := result_encoding Public_key.Response.encoding in
op_gtgteq (Handler.public_key cctxt pkh)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
| Tezos_signer_services.Signer_messages.Request.Authorized_keys =>
let encoding := result_encoding Authorized_keys.Response.encoding in
op_gtgteq
(if require_auth then
op_gtgteqquestion (Handler.Authorized_key.load cctxt)
(fun keys =>
_return
(Tezos_signer_services.Signer_messages.Authorized_keys.Response.Authorized_keys
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply keys List.split) snd)
(List.map Signature.Public_key.hash))))
else
_return
Tezos_signer_services.Signer_messages.Authorized_keys.Response.No_authentication)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
end).
Definition run {B C a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (path : Tezos_stdlib_unix.Lwt_utils_unix.Socket.addr)
(magic_bytes : option (list Z)) (check_high_watermark : bool)
(require_auth : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult (list C)) :=
op_gtgteq
match path with
| Tezos_stdlib_unix.Lwt_utils_unix.Socket.Tcp host service _opts =>
log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accepting TCP requests on " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Accepting TCP requests on %s:%s" % string))
(t event "accepting_tcp_requests" % string)) (s host_name host))
(s service_name service))
| Tezos_stdlib_unix.Lwt_utils_unix.Socket.Unix path =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun signal =>
Sys.set_signal signal
(Stdlib.Sys.Signal_handle
(fun function_parameter =>
let '_ := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Removing the local socket file and quitting." %
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"Removing the local socket file and quitting.@." %
string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Unix.unlink path in
Stdlib.exit 0))) (cons sigint (cons sigterm [])) in
log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accepting UNIX requests on " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Accepting UNIX requests on %s" % string))
(t event "accepting_unix_requests" % string))
(s unix_socket_path path))
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (bind None path)
(fun fds =>
let fix loop {D : Type} (fd : Lwt_unix.file_descr) : Lwt.t D :=
op_gtgteq (Lwt_unix.accept fd)
(fun function_parameter =>
let '(cfd, _) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
protect
(Some
(fun function_parameter =>
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Exn OCaml.End_of_file)
_ => return_unit
| errs => Lwt.return_error errs
end)) None
(fun function_parameter =>
let 'tt := function_parameter in
handle_client magic_bytes check_high_watermark
require_auth cctxt cfd)) in
loop fd) in
op_gtgteq (Lwt_list.map_p loop fds) _return)).
src/bin_validation/main_validator.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let () = Pervasives.exit (Lwt_main.run @@ Validator.main ())
src/bin_validation/main_validator.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/bin_validation/validator.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
let load_protocol proto protocol_root =
if Registered_protocol.mem proto then return_unit
else
let cmxs_file =
protocol_root
// Protocol_hash.to_short_b58check proto
// Format.asprintf "protocol_%a" Protocol_hash.pp proto
in
try
Dynlink.loadfile_private (cmxs_file ^ ".cmxs") ;
return_unit
with Dynlink.Error err ->
Format.ksprintf
(fun msg ->
fail
Block_validator_errors.(
Validation_process_failed (Protocol_dynlink_failure msg)))
"Cannot load file: %s. (Expected location: %s.)"
(Dynlink.error_message err)
cmxs_file
let inconsistent_handshake msg =
Block_validator_errors.(
Validation_process_failed (Inconsistent_handshake msg))
let run stdin stdout =
External_validation.recv stdin Data_encoding.Variable.bytes
>>= fun magic ->
fail_when
(not (Bytes.equal magic External_validation.magic))
(inconsistent_handshake "bad magic")
>>=? fun () ->
External_validation.recv stdin External_validation.parameters_encoding
>>= fun {context_root; protocol_root; sandbox_parameters} ->
let genesis_block = ref Block_hash.zero in
let genesis_time = ref Time.Protocol.epoch in
let genesis_protocol = ref Protocol_hash.zero in
let sandbox_param =
Option.map ~f:(fun p -> ("sandbox_parameter", p)) sandbox_parameters
in
let patch_context ctxt =
( match sandbox_param with
| None ->
Lwt.return ctxt
| Some (key, json) ->
Tezos_storage.Context.set
ctxt
[key]
(Data_encoding.Binary.to_bytes_exn Data_encoding.json json) )
>>= fun ctxt ->
match Registered_protocol.get !genesis_protocol with
| None ->
assert false (* FIXME error *)
| Some proto -> (
let module Proto = (val proto) in
let ctxt = Shell_context.wrap_disk_context ctxt in
Proto.init
ctxt
{
level = 0l;
proto_level = 0;
predecessor = !genesis_block;
timestamp = !genesis_time;
validation_passes = 0;
operations_hash = Operation_list_list_hash.empty;
fitness = [];
context = Context_hash.zero;
}
>>= function
| Error _ ->
assert false (* FIXME error *)
| Ok {context; _} ->
let context = Shell_context.unwrap_disk_context context in
Lwt.return context )
in
Context.init ~patch_context context_root
>>= fun context_index ->
let rec loop () =
External_validation.recv stdin External_validation.request_encoding
>>= (function
| External_validation.Validate
{ chain_id;
block_header;
predecessor_block_header;
operations;
max_operations_ttl } ->
Error_monad.protect (fun () ->
let pred_context_hash =
predecessor_block_header.shell.context
in
Context.checkout context_index pred_context_hash
>>= function
| Some context ->
return context
| None ->
fail
(Block_validator_errors.Failed_to_checkout_context
pred_context_hash))
>>=? (fun predecessor_context ->
Context.get_protocol predecessor_context
>>= fun protocol_hash ->
load_protocol protocol_hash protocol_root
>>=? fun () ->
Block_validation.apply
chain_id
~max_operations_ttl
~predecessor_block_header
~predecessor_context
~block_header
operations
>>= function
| Error
[ Block_validator_errors.Unavailable_protocol
{protocol; _} ] as err -> (
(* If `next_protocol` is missing, try to load it *)
load_protocol protocol protocol_root
>>= function
| Error _ ->
Lwt.return err
| Ok () ->
Block_validation.apply
chain_id
~max_operations_ttl
~predecessor_block_header
~predecessor_context
~block_header
operations )
| result ->
Lwt.return result)
>>= fun res ->
External_validation.send
stdout
(Error_monad.result_encoding Block_validation.result_encoding)
res
| External_validation.Commit_genesis
{chain_id; time; genesis_hash; protocol} ->
genesis_time := time ;
genesis_block := genesis_hash ;
genesis_protocol := protocol ;
Error_monad.protect (fun () ->
Context.commit_genesis
context_index
~chain_id
~time
~protocol
>>= fun commit -> return commit)
>>= fun commit ->
External_validation.send
stdout
(Error_monad.result_encoding Context_hash.encoding)
commit
| External_validation.Init ->
External_validation.send
stdout
(Error_monad.result_encoding Data_encoding.empty)
(Ok ())
| External_validation.Fork_test_chain {context_hash; forked_header}
-> (
Context.checkout context_index context_hash
>>= function
| Some ctxt ->
Block_validation.init_test_chain ctxt forked_header
>>= (function
| Error
[ Block_validator_errors.Missing_test_protocol
protocol ] ->
load_protocol protocol protocol_root
>>=? fun () ->
Block_validation.init_test_chain ctxt forked_header
| result ->
Lwt.return result)
>>= fun result ->
External_validation.send
stdout
(Error_monad.result_encoding Block_header.encoding)
result
| None ->
External_validation.send
stdout
(Error_monad.result_encoding Data_encoding.empty)
(error
(Block_validator_errors.Failed_to_checkout_context
context_hash)) )
| External_validation.Terminate ->
Lwt_io.flush_all () >>= fun () -> exit 0)
>>= fun () -> loop ()
in
loop ()
let main () =
let stdin = Lwt_io.of_fd ~mode:Input Lwt_unix.stdin in
let stdout = Lwt_io.of_fd ~mode:Output Lwt_unix.stdout in
Lwt.catch
(fun () -> run stdin stdout >>=? fun () -> return 0)
(fun e -> Lwt.return (error_exn e))
>>= function
| Ok v ->
Lwt.return v
| Error _ as errs ->
External_validation.send
stdout
(Error_monad.result_encoding Data_encoding.unit)
errs
>>= fun () -> Lwt.return 1
src/bin_validation/validator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition load_protocol
(proto : Tezos_base__TzPervasives.Protocol_hash.t) (protocol_root : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if Registered_protocol.mem proto then
return_unit
else
let cmxs_file :=
op_divdiv
(op_divdiv protocol_root (Protocol_hash.to_short_b58check proto))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "protocol_" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "protocol_%a" % string)
Protocol_hash.pp proto) in
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
Dynlink.loadfile_private (String.append cmxs_file ".cmxs" % string) in
return_unit).
Definition inconsistent_handshake (msg : string)
: Tezos_base__TzPervasives.error :=
Tezos_base__TzPervasives.Validation_process_failed
(Tezos_shell_services.Block_validator_errors.Inconsistent_handshake msg).
Definition run {A : Type}
(stdin : Lwt_io.input_channel) (stdout : Lwt_io.output_channel)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
op_gtgteq (External_validation.recv stdin Data_encoding.Variable.bytes)
(fun magic =>
op_gtgteqquestion
(fail_when (negb (Stdlib.Bytes.equal magic External_validation.magic))
(inconsistent_handshake "bad magic" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(External_validation.recv stdin
External_validation.parameters_encoding)
(fun function_parameter =>
let '{|
context_root := context_root;
protocol_root := protocol_root;
sandbox_parameters := sandbox_parameters
|} := function_parameter in
let genesis_block := Stdlib.ref Block_hash.zero in
let genesis_time := Stdlib.ref Time.Protocol.epoch in
let genesis_protocol := Stdlib.ref Protocol_hash.zero in
let sandbox_param :=
Option.map (fun p => ("sandbox_parameter" % string, p))
sandbox_parameters in
let patch_context (ctxt : Tezos_storage.Context.context)
: Lwt.t Tezos_storage.Context.t :=
op_gtgteq
match sandbox_param with
| None => Lwt._return ctxt
| Some (key, json) =>
Tezos_storage.Context.set ctxt (cons key [])
(Data_encoding.Binary.to_bytes_exn Data_encoding.json json)
end
(fun ctxt =>
match
Registered_protocol.get
(Stdlib.op_exclamation genesis_protocol) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some proto =>
let Proto := projT2 proto in
let ctxt := Shell_context.wrap_disk_context ctxt in
op_gtgteq
(Proto.(Tezos_protocol_updater__Registered_protocol.T.init)
ctxt
{|
level :=
(* ❌ Constant of type int32 is converted to int *)
0; proto_level := 0;
predecessor := Stdlib.op_exclamation genesis_block;
timestamp := Stdlib.op_exclamation genesis_time;
validation_passes := 0;
operations_hash := Operation_list_list_hash.empty;
fitness := []; context := Context_hash.zero |})
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok {| context := context |} =>
let context :=
Shell_context.unwrap_disk_context context in
Lwt._return context
end)
end) in
op_gtgteq
(Context.init (Some patch_context) None None context_root)
(fun context_index =>
let fix loop {B : Type} (function_parameter : unit)
: Lwt.t B :=
let 'tt := function_parameter in
op_gtgteq
(op_gtgteq
(External_validation.recv stdin
External_validation.request_encoding)
(fun function_parameter =>
match function_parameter with
|
Tezos_validation.External_validation.Validate {|
chain_id := chain_id;
block_header := block_header;
predecessor_block_header :=
predecessor_block_header;
operations := operations;
max_operations_ttl := max_operations_ttl
|} =>
op_gtgteq
(op_gtgteqquestion
(Error_monad.protect None None
(fun function_parameter =>
let 'tt := function_parameter in
let pred_context_hash :=
context (shell predecessor_block_header)
in
op_gtgteq
(Context.checkout context_index
pred_context_hash)
(fun function_parameter =>
match function_parameter with
| Some context => _return context
| None =>
fail
(Tezos_base__TzPervasives.Failed_to_checkout_context
pred_context_hash)
end)))
(fun predecessor_context =>
op_gtgteq
(Context.get_protocol predecessor_context)
(fun protocol_hash =>
op_gtgteqquestion
(load_protocol protocol_hash
protocol_root)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block_validation.apply chain_id
max_operations_ttl
predecessor_block_header
predecessor_context block_header
operations)
(fun function_parameter =>
match function_parameter with
|
(Stdlib.Error
(cons
(Tezos_base__TzPervasives.Unavailable_protocol
{| protocol := protocol |})
[])) as err =>
op_gtgteq
(load_protocol protocol
protocol_root)
(fun function_parameter =>
match function_parameter
with
| Stdlib.Error _ =>
Lwt._return err
| Stdlib.Ok tt =>
Block_validation.apply
chain_id
max_operations_ttl
predecessor_block_header
predecessor_context
block_header operations
end)
| result => Lwt._return result
end)))))
(fun res =>
External_validation.send stdout
(Error_monad.result_encoding
Block_validation.result_encoding) res)
|
Tezos_validation.External_validation.Commit_genesis
{|
chain_id := chain_id;
genesis_hash := genesis_hash;
time := time;
protocol := protocol
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq genesis_time time in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq genesis_block genesis_hash in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq genesis_protocol protocol
in
op_gtgteq
(Error_monad.protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Context.commit_genesis context_index
chain_id time protocol)
(fun commit => _return commit)))
(fun commit =>
External_validation.send stdout
(Error_monad.result_encoding
Context_hash.encoding) commit)
| Tezos_validation.External_validation.Init =>
External_validation.send stdout
(Error_monad.result_encoding Data_encoding.empty)
(Stdlib.Ok tt)
|
Tezos_validation.External_validation.Fork_test_chain
{|
context_hash := context_hash;
forked_header := forked_header
|} =>
op_gtgteq
(Context.checkout context_index context_hash)
(fun function_parameter =>
match function_parameter with
| Some ctxt =>
op_gtgteq
(op_gtgteq
(Block_validation.init_test_chain ctxt
forked_header)
(fun function_parameter =>
match function_parameter with
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Missing_test_protocol
protocol) []) =>
op_gtgteqquestion
(load_protocol protocol
protocol_root)
(fun function_parameter =>
let 'tt := function_parameter in
Block_validation.init_test_chain
ctxt forked_header)
| result => Lwt._return result
end))
(fun result =>
External_validation.send stdout
(Error_monad.result_encoding
Block_header.encoding) result)
| None =>
External_validation.send stdout
(Error_monad.result_encoding
Data_encoding.empty)
(error
(Tezos_base__TzPervasives.Failed_to_checkout_context
context_hash))
end)
| Tezos_validation.External_validation.Terminate =>
op_gtgteq (Lwt_io.flush_all tt)
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.exit 0)
end))
(fun function_parameter =>
let 'tt := function_parameter in
loop tt) in
loop tt)))).
Definition main (function_parameter : unit) : Lwt.t Z :=
let 'tt := function_parameter in
let stdin := Lwt_io.of_fd None None Lwt_io.Input Lwt_unix.stdin in
let stdout := Lwt_io.of_fd None None Lwt_io.Output Lwt_unix.stdout in
op_gtgteq
(Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (run stdin stdout)
(fun function_parameter =>
let 'tt := function_parameter in
_return 0)) (fun e => Lwt._return (error_exn e)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok v => Lwt._return v
| (Stdlib.Error _) as errs =>
op_gtgteq
(External_validation.send stdout
(Error_monad.result_encoding Data_encoding.unit) errs)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return 1)
end).
src/lib_base/base_logging.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "base"
end)
let pp_exn_trace ppf backtrace =
if String.length backtrace <> 0 then
Format.fprintf
ppf
"@,Backtrace:@, @[<h>%a@]"
Format.pp_print_text
backtrace
let pid =
Tag.def
~doc:"unix process ID where problem occurred"
"pid"
Format.pp_print_int
let exn_trace =
Tag.def ~doc:"backtrace from native Ocaml exception" "exn_trace" pp_exn_trace
src/lib_base/base_logging.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition pp_exn_trace (ppf : Stdlib.Format.formatter) (backtrace : string)
: unit :=
if nequiv_decb (OCaml.String.length backtrace) 0 then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Backtrace:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h>" % string
CamlinternalFormatBasics.End_of_format) "<h>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@,Backtrace:@, @[<h>%a@]" % string) Format.pp_print_text backtrace
else
tt.
Definition pid : Tag.def Z :=
Tag.def (Some "unix process ID where problem occurred" % string)
"pid" % string Format.pp_print_int.
Definition exn_trace : Tag.def string :=
Tag.def (Some "backtrace from native Ocaml exception" % string)
"exn_trace" % string pp_exn_trace.
src/lib_base/block_header.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type shell_header = {
level : Int32.t;
proto_level : int;
(* uint8 *)
predecessor : Block_hash.t;
timestamp : Time.Protocol.t;
validation_passes : int;
(* uint8 *)
operations_hash : Operation_list_list_hash.t;
fitness : Fitness.t;
context : Context_hash.t;
}
let shell_header_encoding =
let open Data_encoding in
def
"block_header.shell"
~title:"Shell header"
~description:
"Block header's shell-related content. It contains information such as \
the block level, its predecessor and timestamp."
@@ conv
(fun { level;
proto_level;
predecessor;
timestamp;
validation_passes;
operations_hash;
fitness;
context } ->
( level,
proto_level,
predecessor,
timestamp,
validation_passes,
operations_hash,
fitness,
context ))
(fun ( level,
proto_level,
predecessor,
timestamp,
validation_passes,
operations_hash,
fitness,
context ) ->
{
level;
proto_level;
predecessor;
timestamp;
validation_passes;
operations_hash;
fitness;
context;
})
(obj8
(req "level" int32)
(req "proto" uint8)
(req "predecessor" Block_hash.encoding)
(req "timestamp" Time.Protocol.encoding)
(req "validation_pass" uint8)
(req "operations_hash" Operation_list_list_hash.encoding)
(req "fitness" Fitness.encoding)
(req "context" Context_hash.encoding))
type t = {shell : shell_header; protocol_data : Bytes.t}
include Compare.Make (struct
type nonrec t = t
let compare b1 b2 =
let ( >> ) x y = if x = 0 then y () else x in
let rec list compare xs ys =
match (xs, ys) with
| ([], []) ->
0
| (_ :: _, []) ->
-1
| ([], _ :: _) ->
1
| (x :: xs, y :: ys) ->
compare x y >> fun () -> list compare xs ys
in
Block_hash.compare b1.shell.predecessor b2.shell.predecessor
>> fun () ->
compare b1.protocol_data b2.protocol_data
>> fun () ->
Operation_list_list_hash.compare
b1.shell.operations_hash
b2.shell.operations_hash
>> fun () ->
Time.Protocol.compare b1.shell.timestamp b2.shell.timestamp
>> fun () -> list compare b1.shell.fitness b2.shell.fitness
end)
let encoding =
let open Data_encoding in
def
"block_header"
~title:"Block header"
~description:
"Block header. It contains both shell and protocol specific data."
@@ conv
(fun {shell; protocol_data} -> (shell, protocol_data))
(fun (shell, protocol_data) -> {shell; protocol_data})
(merge_objs
shell_header_encoding
(obj1 (req "protocol_data" Variable.bytes)))
let bounded_encoding ?max_size () =
match max_size with
| None ->
encoding
| Some max_size ->
Data_encoding.check_size max_size encoding
let pp ppf op =
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op)
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b
let to_b58check v = Base58.safe_encode (Bytes.to_string (to_bytes v))
let of_b58check b =
Option.apply (Base58.safe_decode b) ~f:(fun s ->
Data_encoding.Binary.of_bytes encoding (Bytes.of_string s))
let hash block = Block_hash.hash_bytes [to_bytes block]
let hash_raw bytes = Block_hash.hash_bytes [bytes]
let forced_protocol_upgrades : (Int32.t * Protocol_hash.t) list =
[ (* nothing *) ]
let voted_protocol_overrides : (Protocol_hash.t * Protocol_hash.t) list =
List.map
(fun (a, b) ->
(Protocol_hash.of_b58check_exn a, Protocol_hash.of_b58check_exn b))
[ (* nothing *) ]
module LevelMap = Map.Make (struct
type t = Int32.t
let compare = Int32.compare
end)
let get_forced_protocol_upgrade =
let table =
List.fold_left
(fun map (level, hash) -> LevelMap.add level hash map)
LevelMap.empty
forced_protocol_upgrades
in
fun ~level -> LevelMap.find_opt level table
let get_voted_protocol_overrides proto_hash =
List.assoc_opt proto_hash voted_protocol_overrides
let () =
Data_encoding.Registration.register shell_header_encoding ;
Data_encoding.Registration.register encoding
src/lib_base/block_header.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record shell_header := {
level : Stdlib.Int32.t;
proto_level : Z;
predecessor : Tezos_crypto.Block_hash.t;
timestamp : Tezos_base.Time.Protocol.t;
validation_passes : Z;
operations_hash : Tezos_crypto.Operation_list_list_hash.t;
fitness : Tezos_base.Fitness.t;
context : Tezos_crypto.Context_hash.t }.
Definition shell_header_encoding
: Tezos_data_encoding.Data_encoding.encoding shell_header :=
apply
(def "block_header.shell" % string (Some "Shell header" % string)
(Some
"Block header's shell-related content. It contains information such as the block level, its predecessor and timestamp."
% string))
(conv
(fun function_parameter =>
let '{|
level := level;
proto_level := proto_level;
predecessor := predecessor;
timestamp := timestamp;
validation_passes := validation_passes;
operations_hash := operations_hash;
fitness := fitness;
context := context
|} := function_parameter in
(level, proto_level, predecessor, timestamp, validation_passes,
operations_hash, fitness, context))
(fun function_parameter =>
let
'(level, proto_level, predecessor, timestamp, validation_passes,
operations_hash, fitness, context) := function_parameter in
{| level := level; proto_level := proto_level;
predecessor := predecessor; timestamp := timestamp;
validation_passes := validation_passes;
operations_hash := operations_hash; fitness := fitness;
context := context |}) None
(obj8 (req None None "level" % string int32)
(req None None "proto" % string uint8)
(req None None "predecessor" % string Block_hash.encoding)
(req None None "timestamp" % string Time.Protocol.encoding)
(req None None "validation_pass" % string uint8)
(req None None "operations_hash" % string
Operation_list_list_hash.encoding)
(req None None "fitness" % string Fitness.encoding)
(req None None "context" % string Context_hash.encoding))).
Record t := {
shell : shell_header;
protocol_data : Stdlib.Bytes.t }.
(* ❌ Structure item `include` not handled. *)
include
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(def "block_header" % string (Some "Block header" % string)
(Some
"Block header. It contains both shell and protocol specific data." %
string))
(conv
(fun function_parameter =>
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
(shell, protocol_data))
(fun function_parameter =>
let '(shell, protocol_data) := function_parameter in
{| shell := shell; protocol_data := protocol_data |}) None
(merge_objs shell_header_encoding
(obj1 (req None None "protocol_data" % string Variable.bytes)))).
Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding t :=
let 'tt := function_parameter in
match max_size with
| None => encoding
| Some max_size => Data_encoding.check_size max_size encoding
end.
Definition pp (ppf : Stdlib.Format.formatter) (op : t) : unit :=
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op).
Definition to_bytes (v : t) : Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding v.
Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
Data_encoding.Binary.of_bytes encoding b.
Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
Data_encoding.Binary.of_bytes_exn encoding b.
Definition to_b58check (v : t) : string :=
Base58.safe_encode None (Stdlib.Bytes.to_string (to_bytes v)).
Definition of_b58check (b : string) : option t :=
Option.apply
(fun s => Data_encoding.Binary.of_bytes encoding (Stdlib.Bytes.of_string s))
(Base58.safe_decode None b).
Definition hash (block : t) : Tezos_crypto.Block_hash.t :=
Block_hash.hash_bytes None (cons (to_bytes block) []).
Definition hash_raw (bytes : Stdlib.Bytes.t) : Tezos_crypto.Block_hash.t :=
Block_hash.hash_bytes None (cons string []).
Definition forced_protocol_upgrades
: list (Stdlib.Int32.t * Tezos_crypto.Protocol_hash.t) := [].
Definition voted_protocol_overrides
: list (Tezos_crypto.Protocol_hash.t * Tezos_crypto.Protocol_hash.t) :=
List.map
(fun function_parameter =>
let '(a, b) := function_parameter in
((Protocol_hash.of_b58check_exn a), (Protocol_hash.of_b58check_exn b))) [].
(* ❌ Applications of functors are not handled. *)
functor_application
Definition get_forced_protocol_upgrade
: LevelMap.key -> option Tezos_crypto.Protocol_hash.t :=
let table :=
Stdlib.List.fold_left
(fun map =>
fun function_parameter =>
let '(level, hash) := function_parameter in
LevelMap.add level hash map) LevelMap.empty forced_protocol_upgrades
in
fun level => LevelMap.find_opt level table.
Definition get_voted_protocol_overrides
(proto_hash : Tezos_crypto.Protocol_hash.t)
: option Tezos_crypto.Protocol_hash.t :=
Stdlib.List.assoc_opt proto_hash voted_protocol_overrides.
src/lib_base/block_locator.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
type t = raw
and raw = Block_header.t * Block_hash.t list
let raw x = x
let pp ppf (hd, h_lst) =
let repeats = 10 in
let coef = 2 in
(* list of hashes *)
let rec pp_hash_list ppf (h_lst, acc, d, r) =
match h_lst with
| [] ->
Format.fprintf ppf ""
| hd :: tl ->
let new_d = if r > 1 then d else d * coef in
let new_r = if r > 1 then r - 1 else repeats in
Format.fprintf
ppf
"%a (%i)\n%a"
Block_hash.pp
hd
acc
pp_hash_list
(tl, acc - d, new_d, new_r)
in
Format.fprintf
ppf
"%a (head)\n%a"
Block_hash.pp
(Block_header.hash hd)
pp_hash_list
(h_lst, -1, 1, repeats - 1)
let pp_short ppf (hd, h_lst) =
Format.fprintf
ppf
"head: %a, %d predecessors"
Block_hash.pp
(Block_header.hash hd)
(List.length h_lst)
let encoding =
let open Data_encoding in
def "block_locator" ~description:"A sparse block locator à la Bitcoin"
@@ obj2
(req "current_head" (dynamic_size Block_header.encoding))
(req "history" (Variable.list Block_hash.encoding))
let bounded_encoding ?max_header_size ?max_length () =
let open Data_encoding in
obj2
(req
"current_head"
(dynamic_size
(Block_header.bounded_encoding ?max_size:max_header_size ())))
(req "history" (Variable.list ?max_length Block_hash.encoding))
type seed = {sender_id : P2p_peer.Id.t; receiver_id : P2p_peer.Id.t}
(* Random generator for locator steps.
We draw steps by sequence of 10. The first sequence's steps are of
length 1 (consecutive). The second sequence's steps are of a random
length between 1 and 2. The third sequence's steps are of a random
length between 2 and 4, and so on...
The sequence is deterministic for a given triple of sender,
receiver and block hash. *)
module Step : sig
type state
val init : seed -> Block_hash.t -> state
val next : state -> int * state
end = struct
(* (step, counter, seed) .
The seed is stored in a bigstring and should be mlocked *)
type state = Int32.t * int * Bigstring.t
let update st b = Hacl.Hash.SHA256.update st (Bigstring.of_bytes b)
let init seed head =
let open Hacl.Hash in
let st = SHA256.init () in
List.iter
(update st)
[ P2p_peer.Id.to_bytes seed.sender_id;
P2p_peer.Id.to_bytes seed.receiver_id;
Block_hash.to_bytes head ] ;
(1l, 9, SHA256.finish st)
let draw seed n =
( Int32.rem (TzEndian.get_int32 (Bigstring.to_bytes seed) 0) n,
Hacl.Hash.SHA256.digest seed )
let next (step, counter, seed) =
let (random_gap, seed) =
if step <= 1l then (0l, seed)
else draw seed (Int32.succ (Int32.div step 2l))
in
let new_state =
if counter = 0 then (Int32.mul step 2l, 9, seed)
else (step, counter - 1, seed)
in
(Int32.to_int (Int32.sub step random_gap), new_state)
end
let estimated_length seed (head, hist) =
let rec loop acc state = function
| [] ->
acc
| _ :: hist ->
let (step, state) = Step.next state in
loop (acc + step) state hist
in
let state = Step.init seed (Block_header.hash head) in
let (step, state) = Step.next state in
loop step state hist
let fold ~f ~init (head, hist) seed =
let rec loop state acc = function
| [] | [_] ->
acc
| block :: (pred :: rem as hist) ->
let (step, state) = Step.next state in
let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
loop state acc hist
in
let head = Block_header.hash head in
let state = Step.init seed head in
loop state init (head :: hist)
type step = {
block : Block_hash.t;
predecessor : Block_hash.t;
step : int;
strict_step : bool;
}
let pp_step ppf step =
Format.fprintf ppf "%d%s" step.step (if step.strict_step then "" else " max")
let to_steps seed locator =
fold locator seed ~init:[] ~f:(fun acc ~block ~pred ~step ~strict_step ->
{block; predecessor = pred; step; strict_step} :: acc)
let fold_truncate ~f ~init ~save_point ~limit (head, hist) seed =
let rec loop state step_sum acc = function
| [] | [_] ->
acc
| block :: (pred :: rem as hist) ->
let (step, state) = Step.next state in
let new_step_sum = step + step_sum in
if new_step_sum >= limit then
f acc ~block ~pred:save_point ~step ~strict_step:false
else
let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
loop state new_step_sum acc hist
in
let hash = Block_header.hash head in
let initial_state = Step.init seed hash in
loop initial_state 0 init (hash :: hist)
let to_steps_truncate ~limit ~save_point seed locator =
fold_truncate
locator
seed
~init:[]
~save_point
~limit
~f:(fun acc ~block ~pred ~step ~strict_step ->
{block; predecessor = pred; step; strict_step} :: acc)
let compute ~get_predecessor ~caboose ~size block_hash header seed =
let rec loop acc size state current_block_hash =
if size = 0 then Lwt.return acc
else
let (step, state) = Step.next state in
get_predecessor current_block_hash step
>>= function
| None ->
if Block_hash.equal caboose current_block_hash then Lwt.return acc
else Lwt.return (caboose :: acc)
| Some predecessor ->
loop (predecessor :: acc) (pred size) state predecessor
in
if size <= 0 then Lwt.return (header, [])
else
let initial_state = Step.init seed block_hash in
loop [] size initial_state block_hash
>>= fun hist -> Lwt.return (header, List.rev hist)
type validity = Unknown | Known_valid | Known_invalid
let unknown_prefix ~is_known locator =
let (head, history) = locator in
let rec loop hist acc =
match hist with
| [] ->
Lwt.return (Unknown, locator)
| h :: t -> (
is_known h
>>= function
| Known_valid ->
Lwt.return (Known_valid, (head, List.rev (h :: acc)))
| Known_invalid ->
Lwt.return (Known_invalid, (head, List.rev (h :: acc)))
| Unknown ->
loop t (h :: acc) )
in
is_known (Block_header.hash head)
>>= function
| Known_valid ->
Lwt.return (Known_valid, (head, []))
| Known_invalid ->
Lwt.return (Known_invalid, (head, []))
| Unknown ->
loop history []
let () = Data_encoding.Registration.register ~pp:pp_short encoding
src/lib_base/block_locator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Reserved Notation "'t".
Reserved Notation "'raw".
where "'t" := ( 'raw)
and "'raw" := ( Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)).
Definition t := 't.
Definition raw := 'raw.
Definition raw {A : Type} (x : A) : A := x.
Definition pp
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : unit :=
let '(hd, h_lst) := function_parameter in
let repeats := 10 in
let coef := 2 in
let fix pp_hash_list
(ppf : Stdlib.Format.formatter) (function_parameter :
(list Tezos_crypto.Block_hash.t) * Z * Z * Z) : unit :=
let '(h_lst, acc, d, r) := function_parameter in
match h_lst with
| [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
"" % string)
| cons hd tl =>
let new_d :=
if OCaml.Stdlib.gt r 1 then
d
else
Z.mul d coef in
let new_r :=
if OCaml.Stdlib.gt r 1 then
Z.sub r 1
else
repeats in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ")
" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))
"%a (%i)
%a" % string) Block_hash.pp hd acc pp_hash_list
(tl, (Z.sub acc d), new_d, new_r)
end in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (head)
" % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)))
"%a (head)
%a" % string) Block_hash.pp (Block_header.hash hd) pp_hash_list
(h_lst, (-1), 1, (Z.sub repeats 1)).
Definition pp_short {A : Type}
(ppf : Stdlib.Format.formatter)
(function_parameter : Tezos_base.Block_header.t * (list A)) : unit :=
let '(hd, h_lst) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " predecessors" % string
CamlinternalFormatBasics.End_of_format)))))
"head: %a, %d predecessors" % string) Block_hash.pp (Block_header.hash hd)
(OCaml.List.length h_lst).
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) :=
apply
(let arg :=
def "block_locator" % string
(* ❌ expected an argument *)
expected_argument (Some "A sparse block locator à la Bitcoin" % string)
in
fun eta => arg None eta)
(obj2
(req None None "current_head" % string
(dynamic_size None Block_header.encoding))
(req None None "history" % string (Variable.list None Block_hash.encoding))).
Definition bounded_encoding
(max_header_size : option Z) (max_length : option Z)
(function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) :=
let 'tt := function_parameter in
obj2
(req None None "current_head" % string
(dynamic_size None (Block_header.bounded_encoding max_header_size tt)))
(req None None "history" % string
(Variable.list max_length Block_hash.encoding)).
Record seed := {
sender_id : Tezos_base.P2p_peer.Id.t;
receiver_id : Tezos_base.P2p_peer.Id.t }.
Module Step.
Definition state := Stdlib.Int32.t * Z * Bigstring.t.
Definition update
(st : Hacl.Hash.SHA256.(Hacl.S.Hash.state)) (b : Stdlib.Bytes.t) : unit :=
Hacl.Hash.SHA256.(Hacl.S.Hash.update) st (Bigstring.of_bytes b).
Definition init (seed : seed) (head : Tezos_crypto.Block_hash.t)
: int32 * Z * Bigstring.t :=
let st := Hacl.Hash.SHA256.(Hacl.Hash.S.init) tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.List.iter (update st)
(cons (P2p_peer.Id.to_bytes (sender_id seed))
(cons (P2p_peer.Id.to_bytes (receiver_id seed))
(cons (Block_hash.to_bytes head) []))) in
((* ❌ Constant of type int32 is converted to int *)
1, 9, (Hacl.Hash.SHA256.(Hacl.Hash.S.finish) st)).
Definition draw (seed : Bigstring.t) (n : int32) : int32 * Bigstring.t :=
((Int32.rem (TzEndian.get_int32 (Bigstring.to_bytes seed) 0) n),
(Hacl.Hash.SHA256.(Hacl.S.Hash.digest) seed)).
Definition next (function_parameter : int32 * Z * Bigstring.t)
: Z * (int32 * Z * Bigstring.t) :=
let '(step, counter, seed) := function_parameter in
let '(random_gap, seed) :=
if
OCaml.Stdlib.le step
(* ❌ Constant of type int32 is converted to int *)
1 then
((* ❌ Constant of type int32 is converted to int *)
0, seed)
else
draw seed
(Int32.succ
(Int32.div step
(* ❌ Constant of type int32 is converted to int *)
2)) in
let new_state :=
if equiv_decb counter 0 then
((Int32.mul step
(* ❌ Constant of type int32 is converted to int *)
2), 9, seed)
else
(step, (Z.sub counter 1), seed) in
((Int32.to_int (Int32.sub step random_gap)), new_state).
End Step.
Definition estimated_length {A : Type}
(seed : seed) (function_parameter : Tezos_base.Block_header.t * (list A))
: Z :=
let '(head, hist) := function_parameter in
let fix loop {B : Type}
(acc : Z) (state : Step.state) (function_parameter : list B) : Z :=
match function_parameter with
| [] => acc
| cons _ hist =>
let '(step, state) := Step.next state in
loop (Z.add acc step) state hist
end in
let state := Step.init seed (Block_header.hash head) in
let '(step, state) := Step.next state in
loop step state hist.
Definition fold {A : Type}
(f :
A ->
Tezos_crypto.Block_hash.t -> Tezos_crypto.Block_hash.t -> Z -> bool -> A)
(init : A)
(function_parameter :
Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : seed -> A :=
let '(head, hist) := function_parameter in
fun seed =>
let fix loop
(state : Step.state) (acc : A) (function_parameter :
list Tezos_crypto.Block_hash.t) : A :=
match function_parameter with
| [] | cons _ [] => acc
| cons block ((cons pred rem) as hist) =>
let '(step, state) := Step.next state in
let acc := f acc block pred step (nequiv_decb rem []) in
loop state acc hist
end in
let head := Block_header.hash head in
let state := Step.init seed head in
loop state init (cons head hist).
Record step := {
block : Tezos_crypto.Block_hash.t;
predecessor : Tezos_crypto.Block_hash.t;
step : Z;
strict_step : bool }.
Definition pp_step (ppf : Stdlib.Format.formatter) (step : step) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "%d%s" % string) (step step)
(if strict_step step then
"" % string
else
" max" % string).
Definition to_steps
(seed : seed)
(locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
: list step :=
fold
(fun acc =>
fun block =>
fun pred =>
fun step =>
fun strict_step =>
cons
{| block := block; predecessor := pred; step := step;
strict_step := strict_step |} acc) [] locator seed.
Definition fold_truncate {A : Type}
(f :
A ->
Tezos_crypto.Block_hash.t -> Tezos_crypto.Block_hash.t -> Z -> bool -> A)
(init : A) (save_point : Tezos_crypto.Block_hash.t) (limit : Z)
(function_parameter :
Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : seed -> A :=
let '(head, hist) := function_parameter in
fun seed =>
let fix loop
(state : Step.state) (step_sum : Z) (acc : A) (function_parameter :
list Tezos_crypto.Block_hash.t) : A :=
match function_parameter with
| [] | cons _ [] => acc
| cons block ((cons pred rem) as hist) =>
let '(step, state) := Step.next state in
let new_step_sum := Z.add step step_sum in
if OCaml.Stdlib.ge new_step_sum limit then
f acc block save_point step false
else
let acc := f acc block pred step (nequiv_decb rem []) in
loop state new_step_sum acc hist
end in
let hash := Block_header.hash head in
let initial_state := Step.init seed hash in
loop initial_state 0 init (cons hash hist).
Definition to_steps_truncate
(limit : Z) (save_point : Tezos_crypto.Block_hash.t) (seed : seed)
(locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
: list step :=
fold_truncate
(fun acc =>
fun block =>
fun pred =>
fun step =>
fun strict_step =>
cons
{| block := block; predecessor := pred; step := step;
strict_step := strict_step |} acc) [] save_point limit locator
seed.
Definition compute {A : Type}
(get_predecessor :
Tezos_crypto.Block_hash.t -> Z -> Lwt.t (option Tezos_crypto.Block_hash.t))
(caboose : Tezos_crypto.Block_hash.t) (size : Z)
(block_hash : Tezos_crypto.Block_hash.t) (header : A) (seed : seed)
: Lwt.t (A * (list Tezos_crypto.Block_hash.t)) :=
let fix loop
(acc : list Tezos_crypto.Block_hash.t) (size : Z) (state : Step.state)
(current_block_hash : Tezos_crypto.Block_hash.t)
: Lwt.t (list Tezos_crypto.Block_hash.t) :=
if equiv_decb size 0 then
Lwt._return acc
else
let '(step, state) := Step.next state in
op_gtgteq (get_predecessor current_block_hash step)
(fun function_parameter =>
match function_parameter with
| None =>
if Block_hash.equal caboose current_block_hash then
Lwt._return acc
else
Lwt._return (cons caboose acc)
| Some predecessor =>
loop (cons predecessor acc) (Z.pred size) state predecessor
end) in
if OCaml.Stdlib.le size 0 then
Lwt._return (header, [])
else
let initial_state := Step.init seed block_hash in
op_gtgteq (loop [] size initial_state block_hash)
(fun hist => Lwt._return (header, (List.rev hist))).
Inductive validity : Type :=
| Unknown : validity
| Known_valid : validity
| Known_invalid : validity.
Definition unknown_prefix
(is_known : Tezos_crypto.Block_hash.t -> Lwt.t validity)
(locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
: Lwt.t
(validity * (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))) :=
let '(head, history) := locator in
let fix loop
(hist : list Tezos_crypto.Block_hash.t) (acc :
list Tezos_crypto.Block_hash.t)
: Lwt.t
(validity * (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))) :=
match hist with
| [] => Lwt._return (Unknown, locator)
| cons h t =>
op_gtgteq (is_known h)
(fun function_parameter =>
match function_parameter with
| Known_valid =>
Lwt._return (Known_valid, (head, (List.rev (cons h acc))))
| Known_invalid =>
Lwt._return (Known_invalid, (head, (List.rev (cons h acc))))
| Unknown => loop t (cons h acc)
end)
end in
op_gtgteq (is_known (Block_header.hash head))
(fun function_parameter =>
match function_parameter with
| Known_valid => Lwt._return (Known_valid, (head, []))
| Known_invalid => Lwt._return (Known_invalid, (head, []))
| Unknown => loop history []
end).
src/lib_base/distributed_db_version.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Distributed_db protocol version. *)
type name = string
let pp_name = Format.pp_print_string
let name_encoding =
let open Data_encoding in
def
"distributed_db_version.name"
~description:"A name for the distributed DB protocol"
string
let chain_name = "TEZOS"
let sandboxed_chain_name = "SANDBOXED_TEZOS"
type t = int
let pp = Format.pp_print_int
let encoding =
let open Data_encoding in
def
"distributed_db_version"
~description:"A version number for the distributed DB protocol"
uint16
let zero = 0
let () =
Data_encoding.Registration.register ~pp:pp_name name_encoding ;
Data_encoding.Registration.register ~pp encoding
src/lib_base/distributed_db_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition name := string.
Definition pp_name : Stdlib.Format.formatter -> string -> unit :=
Format.pp_print_string.
Definition name_encoding : Tezos_data_encoding.Data_encoding.encoding string :=
def "distributed_db_version.name" % string None
(Some "A name for the distributed DB protocol" % string) string.
Definition chain_name : string := "TEZOS" % string.
Definition sandboxed_chain_name : string := "SANDBOXED_TEZOS" % string.
Definition t := Z.
Definition pp : Stdlib.Format.formatter -> Z -> unit := Format.pp_print_int.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
def "distributed_db_version" % string None
(Some "A version number for the distributed DB protocol" % string) uint16.
Definition zero : Z := 0.
src/lib_base/fitness.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Bytes.t list
include Compare.Make (struct
type nonrec t = t
(* Fitness comparison:
- shortest lists are smaller ;
- lexicographical order for lists of the same length. *)
let compare_bytes b1 b2 =
let len1 = Bytes.length b1 in
let len2 = Bytes.length b2 in
let c = compare len1 len2 in
if c <> 0 then c
else
let rec compare_byte b1 b2 pos len =
if pos = len then 0
else
let c = compare (Bytes.get b1 pos) (Bytes.get b2 pos) in
if c <> 0 then c else compare_byte b1 b2 (pos + 1) len
in
compare_byte b1 b2 0 len1
let compare f1 f2 =
let rec compare_rec f1 f2 =
match (f1, f2) with
| ([], []) ->
0
| (i1 :: f1, i2 :: f2) ->
let i = compare_bytes i1 i2 in
if i = 0 then compare_rec f1 f2 else i
| (_, _) ->
assert false
in
let len = compare (List.length f1) (List.length f2) in
if len = 0 then compare_rec f1 f2 else len
end)
let rec pp fmt = function
| [] ->
()
| [f] ->
Format.fprintf fmt "%a" Hex.pp (Hex.of_bytes f)
| f1 :: f ->
Format.fprintf fmt "%a::%a" Hex.pp (Hex.of_bytes f1) pp f
let encoding =
let open Data_encoding in
def
"fitness"
~title:"Block fitness"
~description:
"The fitness, or score, of a block, that allow the Tezos to decide \
which chain is the best. A fitness value is a list of byte sequences. \
They are compared as follows: shortest lists are smaller; lists of the \
same length are compared according to the lexicographical order."
@@ splitted ~json:(list bytes) ~binary:(list (def "fitness.elem" bytes))
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
src/lib_base/fitness.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := list Stdlib.Bytes.t.
(* ❌ Structure item `include` not handled. *)
include
Fixpoint pp (fmt : Stdlib.Format.formatter) (function_parameter : list string)
: unit :=
match function_parameter with
| [] => tt
| cons f [] =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Hex.pp (Hex.of_bytes None f)
| cons f1 f =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "::" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "%a::%a" % string)
Hex.pp (Hex.of_bytes None f1) pp f
end.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding (list Stdlib.Bytes.t) :=
apply
(def "fitness" % string (Some "Block fitness" % string)
(Some
"The fitness, or score, of a block, that allow the Tezos to decide which chain is the best. A fitness value is a list of byte sequences. They are compared as follows: shortest lists are smaller; lists of the same length are compared according to the lexicographical order."
% string))
(splitted (list None bytes)
(list None (def "fitness.elem" % string None None bytes))).
Definition to_bytes (v : list Stdlib.Bytes.t) : Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding v.
Definition of_bytes (b : Stdlib.Bytes.t) : option (list Stdlib.Bytes.t) :=
Data_encoding.Binary.of_bytes encoding b.
src/lib_base/mempool.ml 5 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {known_valid : Operation_hash.t list; pending : Operation_hash.Set.t}
type mempool = t
let encoding =
let open Data_encoding in
def
"mempool"
~description:
"A batch of operation. This format is used to gossip operations between \
peers."
@@ conv
(fun {known_valid; pending} -> (known_valid, pending))
(fun (known_valid, pending) -> {known_valid; pending})
(obj2
(req "known_valid" (list Operation_hash.encoding))
(req "pending" (dynamic_size Operation_hash.Set.encoding)))
let bounded_encoding ?max_operations () =
match max_operations with
| None ->
encoding
| Some max_operations ->
Data_encoding.check_size
(8 + (max_operations * Operation_hash.size))
encoding
let empty = {known_valid = []; pending = Operation_hash.Set.empty}
let () = Data_encoding.Registration.register encoding
src/lib_base/mempool.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
known_valid : list Tezos_crypto.Operation_hash.t;
pending : Tezos_crypto.Operation_hash.Set.t }.
Definition mempool := t.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "mempool" % string
(* ❌ expected an argument *)
expected_argument
(Some
"A batch of operation. This format is used to gossip operations between peers."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{| known_valid := known_valid; pending := pending |} :=
function_parameter in
(known_valid, pending))
(fun function_parameter =>
let '(known_valid, pending) := function_parameter in
{| known_valid := known_valid; pending := pending |}) None
(obj2
(req None None "known_valid" % string
(list None Operation_hash.encoding))
(req None None "pending" % string
(dynamic_size None Operation_hash.Set.encoding)))).
Definition bounded_encoding
(max_operations : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding t :=
let 'tt := function_parameter in
match max_operations with
| None => encoding
| Some max_operations =>
Data_encoding.check_size
(Z.add 8 (Z.mul max_operations Operation_hash.size)) encoding
end.
Definition empty : t :=
{| known_valid := []; pending := Operation_hash.Set.empty |}.
src/lib_base/network_version.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
chain_name : Distributed_db_version.name;
distributed_db_version : Distributed_db_version.t;
p2p_version : P2p_version.t;
}
let pp ppf {chain_name; distributed_db_version; p2p_version} =
Format.fprintf
ppf
"%a.%a (p2p: %a)"
Distributed_db_version.pp_name
chain_name
Distributed_db_version.pp
distributed_db_version
P2p_version.pp
p2p_version
let encoding =
let open Data_encoding in
def
"network_version"
~description:
"A version number for the network protocol (includes distributed DB \
version and p2p version)"
@@ conv
(fun {chain_name; distributed_db_version; p2p_version} ->
(chain_name, distributed_db_version, p2p_version))
(fun (chain_name, distributed_db_version, p2p_version) ->
{chain_name; distributed_db_version; p2p_version})
(obj3
(req "chain_name" Distributed_db_version.name_encoding)
(req "distributed_db_version" Distributed_db_version.encoding)
(req "p2p_version" P2p_version.encoding))
let greatest = function
| [] ->
raise (Invalid_argument "Network_version.greatest")
| h :: t ->
List.fold_left max h t
let announced ~chain_name ~distributed_db_versions ~p2p_versions =
assert (distributed_db_versions <> []) ;
assert (p2p_versions <> []) ;
{
chain_name;
distributed_db_version = greatest distributed_db_versions;
p2p_version = greatest p2p_versions;
}
let may_select_version accepted_versions remote_version =
let best_local_version = greatest accepted_versions in
if best_local_version <= remote_version then Some best_local_version
else if List.mem remote_version accepted_versions then Some remote_version
else None
let select ~chain_name ~distributed_db_versions ~p2p_versions remote =
assert (distributed_db_versions <> []) ;
assert (p2p_versions <> []) ;
if chain_name <> remote.chain_name then None
else
let open Option in
may_select_version distributed_db_versions remote.distributed_db_version
>>= fun distributed_db_version ->
may_select_version p2p_versions remote.p2p_version
>>= fun p2p_version ->
some {chain_name; distributed_db_version; p2p_version}
let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/network_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
chain_name : Tezos_base.Distributed_db_version.name;
distributed_db_version : Tezos_base.Distributed_db_version.t;
p2p_version : Tezos_base.P2p_version.t }.
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
let '{|
chain_name := chain_name;
distributed_db_version := distributed_db_version;
p2p_version := p2p_version
|} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (p2p: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))))
"%a.%a (p2p: %a)" % string) Distributed_db_version.pp_name chain_name
Distributed_db_version.pp distributed_db_version P2p_version.pp p2p_version.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "network_version" % string
(* ❌ expected an argument *)
expected_argument
(Some
"A version number for the network protocol (includes distributed DB version and p2p version)"
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
chain_name := chain_name;
distributed_db_version := distributed_db_version;
p2p_version := p2p_version
|} := function_parameter in
(chain_name, distributed_db_version, p2p_version))
(fun function_parameter =>
let '(chain_name, distributed_db_version, p2p_version) :=
function_parameter in
{| chain_name := chain_name;
distributed_db_version := distributed_db_version;
p2p_version := p2p_version |}) None
(obj3
(req None None "chain_name" % string
Distributed_db_version.name_encoding)
(req None None "distributed_db_version" % string
Distributed_db_version.encoding)
(req None None "p2p_version" % string P2p_version.encoding))).
Definition greatest {A : Type} (function_parameter : list A) : A :=
match function_parameter with
| [] =>
Stdlib.raise (OCaml.Invalid_argument "Network_version.greatest" % string)
| cons h t => Stdlib.List.fold_left OCaml.Stdlib.max h t
end.
Definition announced
(chain_name : Tezos_base.Distributed_db_version.name)
(distributed_db_versions : list Tezos_base.Distributed_db_version.t)
(p2p_versions : list Tezos_base.P2p_version.t) : t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (nequiv_decb distributed_db_versions []) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (nequiv_decb p2p_versions []) in
{| chain_name := chain_name;
distributed_db_version := greatest distributed_db_versions;
p2p_version := greatest p2p_versions |}.
Definition may_select_version {A : Type}
(accepted_versions : list A) (remote_version : A) : option A :=
let best_local_version := greatest accepted_versions in
if OCaml.Stdlib.le best_local_version remote_version then
Some best_local_version
else
if Stdlib.List.mem remote_version accepted_versions then
Some remote_version
else
None.
Definition select
(chain_name : Tezos_base.Distributed_db_version.name)
(distributed_db_versions : list Tezos_base.Distributed_db_version.t)
(p2p_versions : list Tezos_base.P2p_version.t) (remote : t) : option t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (nequiv_decb distributed_db_versions []) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (nequiv_decb p2p_versions []) in
if nequiv_decb chain_name (chain_name remote) then
None
else
op_gtgteq
(may_select_version distributed_db_versions
(distributed_db_version remote))
(fun distributed_db_version =>
op_gtgteq (may_select_version p2p_versions (p2p_version remote))
(fun p2p_version =>
some
{| chain_name := chain_name;
distributed_db_version := distributed_db_version;
p2p_version := p2p_version |})).
src/lib_base/operation.ml 13 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type shell_header = {branch : Block_hash.t}
let shell_header_encoding =
let open Data_encoding in
def "operation.shell_header" ~description:"An operation's shell header."
@@ conv
(fun {branch} -> branch)
(fun branch -> {branch})
(obj1 (req "branch" Block_hash.encoding))
type t = {shell : shell_header; proto : Bytes.t}
include Compare.Make (struct
type nonrec t = t
let compare o1 o2 =
let ( >> ) x y = if x = 0 then y () else x in
Block_hash.compare o1.shell.branch o1.shell.branch
>> fun () -> Bytes.compare o1.proto o2.proto
end)
let encoding =
let open Data_encoding in
def
"operation"
~description:
"An operation. The shell_header part indicates a block an operation is \
meant to apply on top of. The proto part is protocol-specific and \
appears as a binary blob."
@@ conv
(fun {shell; proto} -> (shell, proto))
(fun (shell, proto) -> {shell; proto})
(merge_objs shell_header_encoding (obj1 (req "data" Variable.bytes)))
let bounded_encoding ?max_size () =
match max_size with
| None ->
encoding
| Some max_size ->
Data_encoding.check_size max_size encoding
let bounded_list_encoding ?max_length ?max_size ?max_operation_size ?max_pass
() =
let open Data_encoding in
let op_encoding = bounded_encoding ?max_size:max_operation_size () in
let op_list_encoding =
match max_size with
| None ->
Variable.list ?max_length (dynamic_size op_encoding)
| Some max_size ->
check_size
max_size
(Variable.list ?max_length (dynamic_size op_encoding))
in
obj2
(req
"operation_hashes_path"
(Operation_list_list_hash.bounded_path_encoding ?max_length:max_pass ()))
(req "operations" op_list_encoding)
let bounded_hash_list_encoding ?max_length ?max_pass () =
let open Data_encoding in
obj2
(req
"operation_hashes_path"
(Operation_list_list_hash.bounded_path_encoding ?max_length:max_pass ()))
(req "operation_hashes" (Variable.list ?max_length Operation_hash.encoding))
let pp fmt op =
Data_encoding.Json.pp fmt (Data_encoding.Json.construct encoding op)
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b
let hash op = Operation_hash.hash_bytes [to_bytes op]
let hash_raw bytes = Operation_hash.hash_bytes [bytes]
let () =
Data_encoding.Registration.register ~pp encoding ;
Data_encoding.Registration.register shell_header_encoding
src/lib_base/operation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record shell_header := {
branch : Tezos_crypto.Block_hash.t }.
Definition shell_header_encoding
: Tezos_data_encoding.Data_encoding.encoding shell_header :=
apply
(let arg :=
def "operation.shell_header" % string
(* ❌ expected an argument *)
expected_argument (Some "An operation's shell header." % string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{| branch := branch |} := function_parameter in
branch) (fun branch => {| branch := branch |}) None
(obj1 (req None None "branch" % string Block_hash.encoding))).
Record t := {
shell : shell_header;
proto : Stdlib.Bytes.t }.
(* ❌ Structure item `include` not handled. *)
include
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "operation" % string
(* ❌ expected an argument *)
expected_argument
(Some
"An operation. The shell_header part indicates a block an operation is meant to apply on top of. The proto part is protocol-specific and appears as a binary blob."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{| shell := shell; proto := proto |} := function_parameter in
(shell, proto))
(fun function_parameter =>
let '(shell, proto) := function_parameter in
{| shell := shell; proto := proto |}) None
(merge_objs shell_header_encoding
(obj1 (req None None "data" % string Variable.bytes)))).
Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding t :=
let 'tt := function_parameter in
match max_size with
| None => encoding
| Some max_size => Data_encoding.check_size max_size encoding
end.
Definition bounded_list_encoding
(max_length : option Z) (max_size : option Z) (max_operation_size : option Z)
(max_pass : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_crypto.Operation_list_list_hash.path * (list t)) :=
let 'tt := function_parameter in
let op_encoding := bounded_encoding max_operation_size tt in
let op_list_encoding :=
match max_size with
| None => Variable.list max_length (dynamic_size None op_encoding)
| Some max_size =>
check_size max_size
(Variable.list max_length (dynamic_size None op_encoding))
end in
obj2
(req None None "operation_hashes_path" % string
(Operation_list_list_hash.bounded_path_encoding max_pass tt))
(req None None "operations" % string op_list_encoding).
Definition bounded_hash_list_encoding
(max_length : option Z) (max_pass : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_crypto.Operation_list_list_hash.path *
(list Tezos_crypto.Operation_hash.t)) :=
let 'tt := function_parameter in
obj2
(req None None "operation_hashes_path" % string
(Operation_list_list_hash.bounded_path_encoding max_pass tt))
(req None None "operation_hashes" % string
(Variable.list max_length Operation_hash.encoding)).
Definition pp (fmt : Stdlib.Format.formatter) (op : t) : unit :=
Data_encoding.Json.pp fmt (Data_encoding.Json.construct encoding op).
Definition to_bytes (v : t) : Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding v.
Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
Data_encoding.Binary.of_bytes encoding b.
Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
Data_encoding.Binary.of_bytes_exn encoding b.
Definition hash (op : t) : Tezos_crypto.Operation_hash.t :=
Operation_hash.hash_bytes None (cons (to_bytes op) []).
Definition hash_raw (bytes : Stdlib.Bytes.t) : Tezos_crypto.Operation_hash.t :=
Operation_hash.hash_bytes None (cons string []).
src/lib_base/p2p_addr.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Ipaddr.V6.t
let encoding =
let open Data_encoding in
def "p2p_address" ~description:"An address for locating peers."
@@ splitted
~json:(conv Ipaddr.V6.to_string Ipaddr.V6.of_string_exn string)
~binary:(conv Ipaddr.V6.to_octets Ipaddr.V6.of_octets_exn string)
type port = int
let pp ppf addr =
match Ipaddr.v4_of_v6 addr with
| Some addr ->
Format.fprintf ppf "%a" Ipaddr.V4.pp addr
| None ->
Format.fprintf ppf "[%a]" Ipaddr.V6.pp addr
let of_string_opt str =
match Ipaddr.of_string str with
| Ok (Ipaddr.V4 addr) ->
Some (Ipaddr.v6_of_v4 addr)
| Ok (V6 addr) ->
Some addr
| Error (`Msg _) ->
None
let of_string_exn str =
match of_string_opt str with
| None ->
Pervasives.failwith "P2p_addr.of_string"
| Some t ->
t
let to_string saddr = Format.asprintf "%a" pp saddr
let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_addr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Ipaddr.V6.t.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Ipaddr.V6.t :=
apply
(let arg :=
def "p2p_address" % string
(* ❌ expected an argument *)
expected_argument (Some "An address for locating peers." % string) in
fun eta => arg None eta)
(splitted (conv Ipaddr.V6.to_string Ipaddr.V6.of_string_exn None string)
(conv Ipaddr.V6.to_octets
(let arg := Ipaddr.V6.of_octets_exn in
fun eta => arg None eta) None string)).
Definition port := Z.
Definition pp (ppf : Stdlib.Format.formatter) (addr : Ipaddr.V6.t) : unit :=
match Ipaddr.v4_of_v6 addr with
| Some addr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Ipaddr.V4.pp addr
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "]" % char
CamlinternalFormatBasics.End_of_format))) "[%a]" % string)
Ipaddr.V6.pp addr
end.
Definition of_string_opt (str : string) : option Ipaddr.V6.t :=
match Ipaddr.of_string str with
| Stdlib.Ok (Ipaddr.V4 addr) => Some (Ipaddr.v6_of_v4 addr)
| Stdlib.Ok (Ipaddr.V6 addr) => Some addr
| Stdlib.Error (Msg _) => None
end.
Definition of_string_exn (str : string) : Ipaddr.V6.t :=
match of_string_opt str with
| None => Pervasives.failwith "P2p_addr.of_string" % string
| Some t => t
end.
Definition to_string (saddr : Ipaddr.V6.t) : string :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp saddr.
src/lib_base/p2p_connection.ml 54 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Id = struct
(* A net point (address x port). *)
type t = P2p_addr.t * P2p_addr.port option
let compare (a1, p1) (a2, p2) =
match Ipaddr.V6.compare a1 a2 with 0 -> Pervasives.compare p1 p2 | x -> x
let equal p1 p2 = compare p1 p2 = 0
let hash = Hashtbl.hash
let pp ppf (addr, port) =
match port with
| None ->
Format.fprintf ppf "[%a]:??" Ipaddr.V6.pp addr
| Some port ->
Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp addr port
let pp_opt ppf = function
| None ->
Format.pp_print_string ppf "none"
| Some point ->
pp ppf point
let to_string t = Format.asprintf "%a" pp t
let is_local (addr, _) = Ipaddr.V6.is_private addr
let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
let of_point (addr, port) = (addr, Some port)
let to_point = function
| (_, None) ->
None
| (addr, Some port) ->
Some (addr, port)
let to_point_exn = function
| (_, None) ->
invalid_arg "to_point_exn"
| (addr, Some port) ->
(addr, port)
let encoding =
let open Data_encoding in
def
"p2p_connection.id"
~description:
"The identifier for a p2p connection. It includes an address and a \
port number."
@@ obj2 (req "addr" P2p_addr.encoding) (opt "port" uint16)
end
module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)
module Info = struct
type 'meta t = {
incoming : bool;
peer_id : P2p_peer_id.t;
id_point : Id.t;
remote_socket_port : P2p_addr.port;
announced_version : Network_version.t;
private_node : bool;
local_metadata : 'meta;
remote_metadata : 'meta;
}
let encoding metadata_encoding =
let open Data_encoding in
conv
(fun { incoming;
peer_id;
id_point;
remote_socket_port;
announced_version;
private_node;
local_metadata;
remote_metadata } ->
( incoming,
peer_id,
id_point,
remote_socket_port,
announced_version,
private_node,
local_metadata,
remote_metadata ))
(fun ( incoming,
peer_id,
id_point,
remote_socket_port,
announced_version,
private_node,
local_metadata,
remote_metadata ) ->
{
incoming;
peer_id;
id_point;
remote_socket_port;
announced_version;
private_node;
local_metadata;
remote_metadata;
})
(obj8
(req "incoming" bool)
(req "peer_id" P2p_peer_id.encoding)
(req "id_point" Id.encoding)
(req "remote_socket_port" uint16)
(req "announced_version" Network_version.encoding)
(req "private" bool)
(req "local_metadata" metadata_encoding)
(req "remote_metadata" metadata_encoding))
let pp pp_meta ppf
{ incoming;
id_point = (remote_addr, remote_port);
remote_socket_port;
peer_id;
announced_version;
private_node;
local_metadata = _;
remote_metadata } =
let point =
match remote_port with
| None ->
(remote_addr, remote_socket_port)
| Some port ->
(remote_addr, port)
in
Format.fprintf
ppf
"%s %a %a (%a) %s%a"
(if incoming then "â" else "â")
P2p_peer_id.pp
peer_id
P2p_point.Id.pp
point
Network_version.pp
announced_version
(if private_node then " private" else "")
pp_meta
remote_metadata
end
module P2p_event = struct
(** Pool-level events *)
type t =
| Too_few_connections
| Too_many_connections
| New_point of P2p_point.Id.t
| New_peer of P2p_peer_id.t
| Gc_points
| Gc_peer_ids
| Incoming_connection of P2p_point.Id.t
| Outgoing_connection of P2p_point.Id.t
| Authentication_failed of P2p_point.Id.t
| Accepting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
| Rejecting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
| Request_rejected of P2p_point.Id.t * (Id.t * P2p_peer_id.t) option
| Connection_established of Id.t * P2p_peer_id.t
| Swap_request_received of {source : P2p_peer_id.t}
| Swap_ack_received of {source : P2p_peer_id.t}
| Swap_request_sent of {source : P2p_peer_id.t}
| Swap_ack_sent of {source : P2p_peer_id.t}
| Swap_request_ignored of {source : P2p_peer_id.t}
| Swap_success of {source : P2p_peer_id.t}
| Swap_failure of {source : P2p_peer_id.t}
| Disconnection of P2p_peer_id.t
| External_disconnection of P2p_peer_id.t
let pp ppf (event : t) =
match event with
| Too_few_connections ->
Format.pp_print_string ppf "Too_few_connections"
| Too_many_connections ->
Format.pp_print_string ppf "Too_many_connections"
| New_point p ->
Format.pp_print_string ppf "New_point " ;
P2p_point.Id.pp ppf p
| New_peer p ->
Format.pp_print_string ppf "New_peer " ;
P2p_peer_id.pp ppf p
| Gc_points ->
Format.pp_print_string ppf "Gc_points"
| Gc_peer_ids ->
Format.pp_print_string ppf "Gc_peer_ids"
| Incoming_connection p ->
Format.pp_print_string ppf "Incoming_connection " ;
P2p_point.Id.pp ppf p
| Outgoing_connection p ->
Format.pp_print_string ppf "Outgoing_connection " ;
P2p_point.Id.pp ppf p
| Authentication_failed p ->
Format.pp_print_string ppf "Authentication_failed " ;
P2p_point.Id.pp ppf p
| Accepting_request (pi, _, _) ->
Format.pp_print_string ppf "Accepting_request " ;
P2p_point.Id.pp ppf pi
| Rejecting_request (pi, _, _) ->
Format.pp_print_string ppf "Rejecting_request " ;
P2p_point.Id.pp ppf pi
| Request_rejected (pi, _) ->
Format.pp_print_string ppf "Request_rejected " ;
P2p_point.Id.pp ppf pi
| Connection_established (_, pi) ->
Format.pp_print_string ppf "Connection_established " ;
P2p_peer_id.pp ppf pi
| Swap_request_received {source} ->
Format.pp_print_string ppf "Swap_request_received " ;
P2p_peer_id.pp ppf source
| Swap_ack_received {source} ->
Format.pp_print_string ppf "Swap_ack_received " ;
P2p_peer_id.pp ppf source
| Swap_request_sent {source} ->
Format.pp_print_string ppf "Swap_request_sent " ;
P2p_peer_id.pp ppf source
| Swap_ack_sent {source} ->
Format.pp_print_string ppf "Swap_ack_sent " ;
P2p_peer_id.pp ppf source
| Swap_request_ignored {source} ->
Format.pp_print_string ppf "Swap_request_ignored " ;
P2p_peer_id.pp ppf source
| Swap_success {source} ->
Format.pp_print_string ppf "Swap_success " ;
P2p_peer_id.pp ppf source
| Swap_failure {source} ->
Format.pp_print_string ppf "Swap_failure " ;
P2p_peer_id.pp ppf source
| Disconnection source ->
Format.pp_print_string ppf "Disconnection " ;
P2p_peer_id.pp ppf source
| External_disconnection source ->
Format.pp_print_string ppf "External_disconnection " ;
P2p_peer_id.pp ppf source
let encoding =
let open Data_encoding in
let branch_encoding name obj =
conv
(fun x -> ((), x))
(fun ((), x) -> x)
(merge_objs (obj1 (req "event" (constant name))) obj)
in
def
"p2p_connection.pool_event"
~description:
"An event that may happen during maintenance of and other operations \
on the p2p connection pool. Typically, it includes connection \
errors, peer swaps, etc."
@@ union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Too_few_connections"
(branch_encoding "too_few_connections" empty)
(function Too_few_connections -> Some () | _ -> None)
(fun () -> Too_few_connections);
case
(Tag 1)
~title:"Too_many_connections"
(branch_encoding "too_many_connections" empty)
(function Too_many_connections -> Some () | _ -> None)
(fun () -> Too_many_connections);
case
(Tag 2)
~title:"New_point"
(branch_encoding
"new_point"
(obj1 (req "point" P2p_point.Id.encoding)))
(function New_point p -> Some p | _ -> None)
(fun p -> New_point p);
case
(Tag 3)
~title:"New_peer"
(branch_encoding
"new_peer"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function New_peer p -> Some p | _ -> None)
(fun p -> New_peer p);
case
(Tag 4)
~title:"Incoming_connection"
(branch_encoding
"incoming_connection"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Incoming_connection p -> Some p | _ -> None)
(fun p -> Incoming_connection p);
case
(Tag 5)
~title:"Outgoing_connection"
(branch_encoding
"outgoing_connection"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Outgoing_connection p -> Some p | _ -> None)
(fun p -> Outgoing_connection p);
case
(Tag 6)
~title:"Authentication_failed"
(branch_encoding
"authentication_failed"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Authentication_failed p -> Some p | _ -> None)
(fun p -> Authentication_failed p);
case
(Tag 7)
~title:"Accepting_request"
(branch_encoding
"accepting_request"
(obj3
(req "point" P2p_point.Id.encoding)
(req "id_point" Id.encoding)
(req "peer_id" P2p_peer_id.encoding)))
(function
| Accepting_request (p, id_p, g) ->
Some (p, id_p, g)
| _ ->
None)
(fun (p, id_p, g) -> Accepting_request (p, id_p, g));
case
(Tag 8)
~title:"Rejecting_request"
(branch_encoding
"rejecting_request"
(obj3
(req "point" P2p_point.Id.encoding)
(req "id_point" Id.encoding)
(req "peer_id" P2p_peer_id.encoding)))
(function
| Rejecting_request (p, id_p, g) ->
Some (p, id_p, g)
| _ ->
None)
(fun (p, id_p, g) -> Rejecting_request (p, id_p, g));
case
(Tag 9)
~title:"Request_rejected"
(branch_encoding
"request_rejected"
(obj2
(req "point" P2p_point.Id.encoding)
(opt "identity" (tup2 Id.encoding P2p_peer_id.encoding))))
(function Request_rejected (p, id) -> Some (p, id) | _ -> None)
(fun (p, id) -> Request_rejected (p, id));
case
(Tag 10)
~title:"Connection_established"
(branch_encoding
"connection_established"
(obj2
(req "id_point" Id.encoding)
(req "peer_id" P2p_peer_id.encoding)))
(function
| Connection_established (id_p, g) -> Some (id_p, g) | _ -> None)
(fun (id_p, g) -> Connection_established (id_p, g));
case
(Tag 11)
~title:"Disconnection"
(branch_encoding
"disconnection"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function Disconnection g -> Some g | _ -> None)
(fun g -> Disconnection g);
case
(Tag 12)
~title:"External_disconnection"
(branch_encoding
"external_disconnection"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function External_disconnection g -> Some g | _ -> None)
(fun g -> External_disconnection g);
case
(Tag 13)
~title:"Gc_points"
(branch_encoding "gc_points" empty)
(function Gc_points -> Some () | _ -> None)
(fun () -> Gc_points);
case
(Tag 14)
~title:"Gc_peer_ids"
(branch_encoding "gc_peer_ids" empty)
(function Gc_peer_ids -> Some () | _ -> None)
(fun () -> Gc_peer_ids);
case
(Tag 15)
~title:"Swap_request_received"
(branch_encoding
"swap_request_received"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
| Swap_request_received {source} -> Some source | _ -> None)
(fun source -> Swap_request_received {source});
case
(Tag 16)
~title:"Swap_ack_received"
(branch_encoding
"swap_ack_received"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_ack_received {source} -> Some source | _ -> None)
(fun source -> Swap_ack_received {source});
case
(Tag 17)
~title:"Swap_request_sent"
(branch_encoding
"swap_request_sent"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_request_sent {source} -> Some source | _ -> None)
(fun source -> Swap_request_sent {source});
case
(Tag 18)
~title:"Swap_ack_sent"
(branch_encoding
"swap_ack_sent"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_ack_sent {source} -> Some source | _ -> None)
(fun source -> Swap_ack_sent {source});
case
(Tag 19)
~title:"Swap_request_ignored"
(branch_encoding
"swap_request_ignored"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
| Swap_request_ignored {source} -> Some source | _ -> None)
(fun source -> Swap_request_ignored {source});
case
(Tag 20)
~title:"Swap_success"
(branch_encoding
"swap_success"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_success {source} -> Some source | _ -> None)
(fun source -> Swap_success {source});
case
(Tag 21)
~title:"Swap_failure"
(branch_encoding
"swap_failure"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_failure {source} -> Some source | _ -> None)
(fun source -> Swap_failure {source}) ]
end
let () =
Data_encoding.Registration.register ~pp:Id.pp Id.encoding ;
Data_encoding.Registration.register ~pp:P2p_event.pp P2p_event.encoding
src/lib_base/p2p_connection.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Id.
Definition t := Tezos_base.P2p_addr.t * (option Tezos_base.P2p_addr.port).
Definition compare {A : Type} (function_parameter : Ipaddr.V6.t * A)
: (Ipaddr.V6.t * A) -> Z :=
let '(a1, p1) := function_parameter in
fun function_parameter =>
let '(a2, p2) := function_parameter in
match Ipaddr.V6.compare a1 a2 with
| 0 => Pervasives.compare p1 p2
| x => x
end.
Definition equal {A : Type} (p1 : Ipaddr.V6.t * A) (p2 : Ipaddr.V6.t * A)
: bool := equiv_decb (compare p1 p2) 0.
Definition hash {A : Type} : A -> Z := Hashtbl.hash.
Definition pp
(ppf : Stdlib.Format.formatter)
(function_parameter : Ipaddr.V6.t * (option Z)) : unit :=
let '(addr, port) := function_parameter in
match port with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "]:??" % string
CamlinternalFormatBasics.End_of_format))) "[%a]:??" % string)
Ipaddr.V6.pp addr
| Some port =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "]:" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))) "[%a]:%d" % string)
Ipaddr.V6.pp addr port
end.
Definition pp_opt
(ppf : Stdlib.Format.formatter)
(function_parameter : option (Ipaddr.V6.t * (option Z))) : unit :=
match function_parameter with
| None => Format.pp_print_string ppf "none" % string
| Some point => pp ppf point
end.
Definition to_string (t : Ipaddr.V6.t * (option Z)) : string :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp t.
Definition is_local {A : Type} (function_parameter : Ipaddr.V6.t * A)
: bool :=
let '(addr, _) := function_parameter in
Ipaddr.V6.is_private addr.
Definition is_global {A : Type} (function_parameter : Ipaddr.V6.t * A)
: bool :=
let '(addr, _) := function_parameter in
apply negb (Ipaddr.V6.is_private addr).
Definition of_point {A B : Type} (function_parameter : A * B)
: A * (option B) :=
let '(addr, port) := function_parameter in
(addr, (Some port)).
Definition to_point {A B : Type} (function_parameter : A * (option B))
: option (A * B) :=
match function_parameter with
| (_, None) => None
| (addr, Some port) => Some (addr, port)
end.
Definition to_point_exn {A B : Type} (function_parameter : A * (option B))
: A * B :=
match function_parameter with
| (_, None) => OCaml.Stdlib.invalid_arg "to_point_exn" % string
| (addr, Some port) => (addr, port)
end.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_base.P2p_addr.t * (option Z)) :=
apply
(let arg :=
def "p2p_connection.id" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The identifier for a p2p connection. It includes an address and a port number."
% string) in
fun eta => arg None eta)
(obj2 (req None None "addr" % string P2p_addr.encoding)
(opt None None "port" % string uint16)).
End Id.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module Info.
Record t {meta : Type} := {
incoming : bool;
peer_id : Tezos_base.P2p_peer_id.t;
id_point : Id.t;
remote_socket_port : Tezos_base.P2p_addr.port;
announced_version : Tezos_base.Network_version.t;
private_node : bool;
local_metadata : meta;
remote_metadata : meta }.
Arguments t : clear implicits.
Definition encoding {A : Type}
(metadata_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (t A) :=
conv
(fun function_parameter =>
let '{|
incoming := incoming;
peer_id := peer_id;
id_point := id_point;
remote_socket_port := remote_socket_port;
announced_version := announced_version;
private_node := private_node;
local_metadata := local_metadata;
remote_metadata := remote_metadata
|} := function_parameter in
(incoming, peer_id, id_point, remote_socket_port, announced_version,
private_node, local_metadata, remote_metadata))
(fun function_parameter =>
let
'(incoming, peer_id, id_point, remote_socket_port, announced_version,
private_node, local_metadata, remote_metadata) := function_parameter
in
{| incoming := incoming; peer_id := peer_id; id_point := id_point;
remote_socket_port := remote_socket_port;
announced_version := announced_version; private_node := private_node;
local_metadata := local_metadata; remote_metadata := remote_metadata
|}) None
(obj8 (req None None "incoming" % string bool)
(req None None "peer_id" % string P2p_peer_id.encoding)
(req None None "id_point" % string Id.encoding)
(req None None "remote_socket_port" % string uint16)
(req None None "announced_version" % string Network_version.encoding)
(req None None "private" % string bool)
(req None None "local_metadata" % string metadata_encoding)
(req None None "remote_metadata" % string metadata_encoding)).
Definition pp {A : Type}
(pp_meta : Stdlib.Format.formatter -> A -> unit)
(ppf : Stdlib.Format.formatter) (function_parameter : t A) : unit :=
let '{|
incoming := incoming;
peer_id := peer_id;
id_point := (remote_addr, remote_port);
remote_socket_port := remote_socket_port;
announced_version := announced_version;
private_node := private_node;
local_metadata := _;
remote_metadata := remote_metadata
|} := function_parameter in
let point :=
match remote_port with
| None => (remote_addr, remote_socket_port)
| Some port => (remote_addr, port)
end in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ") " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))))))
"%s %a %a (%a) %s%a" % string)
(if incoming then
"↘" % string
else
"↗" % string) P2p_peer_id.pp peer_id P2p_point.Id.pp point
Network_version.pp announced_version
(if private_node then
" private" % string
else
"" % string) pp_meta remote_metadata.
End Info.
Module P2p_event.
Inductive t : Type :=
| Too_few_connections : t
| Too_many_connections : t
| New_point : Tezos_base.P2p_point.Id.t -> t
| New_peer : Tezos_base.P2p_peer_id.t -> t
| Gc_points : t
| Gc_peer_ids : t
| Incoming_connection : Tezos_base.P2p_point.Id.t -> t
| Outgoing_connection : Tezos_base.P2p_point.Id.t -> t
| Authentication_failed : Tezos_base.P2p_point.Id.t -> t
| Accepting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
Tezos_base.P2p_peer_id.t -> t
| Rejecting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
Tezos_base.P2p_peer_id.t -> t
| Request_rejected : Tezos_base.P2p_point.Id.t ->
(option (Id.t * Tezos_base.P2p_peer_id.t)) -> t
| Connection_established : Id.t -> Tezos_base.P2p_peer_id.t -> t
| Swap_request_received : Tezos_base.P2p_peer_id.t -> t
| Swap_ack_received : Tezos_base.P2p_peer_id.t -> t
| Swap_request_sent : Tezos_base.P2p_peer_id.t -> t
| Swap_ack_sent : Tezos_base.P2p_peer_id.t -> t
| Swap_request_ignored : Tezos_base.P2p_peer_id.t -> t
| Swap_success : Tezos_base.P2p_peer_id.t -> t
| Swap_failure : Tezos_base.P2p_peer_id.t -> t
| Disconnection : Tezos_base.P2p_peer_id.t -> t
| External_disconnection : Tezos_base.P2p_peer_id.t -> t.
Definition pp (ppf : Stdlib.Format.formatter) (event : t) : unit :=
match event with
| Too_few_connections =>
Format.pp_print_string ppf "Too_few_connections" % string
| Too_many_connections =>
Format.pp_print_string ppf "Too_many_connections" % string
| New_point p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "New_point " % string in
P2p_point.Id.pp ppf p
| New_peer p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "New_peer " % string in
P2p_peer_id.pp ppf p
| Gc_points => Format.pp_print_string ppf "Gc_points" % string
| Gc_peer_ids => Format.pp_print_string ppf "Gc_peer_ids" % string
| Incoming_connection p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Incoming_connection " % string in
P2p_point.Id.pp ppf p
| Outgoing_connection p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Outgoing_connection " % string in
P2p_point.Id.pp ppf p
| Authentication_failed p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Authentication_failed " % string in
P2p_point.Id.pp ppf p
| Accepting_request pi _ _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Accepting_request " % string in
P2p_point.Id.pp ppf pi
| Rejecting_request pi _ _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Rejecting_request " % string in
P2p_point.Id.pp ppf pi
| Request_rejected pi _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Request_rejected " % string in
P2p_point.Id.pp ppf pi
| Connection_established _ pi =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Connection_established " % string in
P2p_peer_id.pp ppf pi
| Swap_request_received {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_request_received " % string in
P2p_peer_id.pp ppf source
| Swap_ack_received {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_ack_received " % string in
P2p_peer_id.pp ppf source
| Swap_request_sent {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_request_sent " % string in
P2p_peer_id.pp ppf source
| Swap_ack_sent {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_ack_sent " % string in
P2p_peer_id.pp ppf source
| Swap_request_ignored {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_request_ignored " % string in
P2p_peer_id.pp ppf source
| Swap_success {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_success " % string in
P2p_peer_id.pp ppf source
| Swap_failure {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_failure " % string in
P2p_peer_id.pp ppf source
| Disconnection source =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Disconnection " % string in
P2p_peer_id.pp ppf source
| External_disconnection source =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "External_disconnection " % string in
P2p_peer_id.pp ppf source
end.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
let branch_encoding {A : Type}
(name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding A :=
conv (fun x => (tt, x))
(fun function_parameter =>
let '(tt, x) := function_parameter in
x) None
(merge_objs (obj1 (req None None "event" % string (constant name))) obj)
in
apply
(let arg :=
def "p2p_connection.pool_event" % string
(* ❌ expected an argument *)
expected_argument
(Some
"An event that may happen during maintenance of and other operations on the p2p connection pool. Typically, it includes connection errors, peer swaps, etc."
% string) in
fun eta => arg None eta)
(union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Too_few_connections" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(branch_encoding "too_few_connections" % string empty)
(fun function_parameter =>
match function_parameter with
| Too_few_connections => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Too_few_connections))
(cons
(case "Too_many_connections" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(branch_encoding "too_many_connections" % string empty)
(fun function_parameter =>
match function_parameter with
| Too_many_connections => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Too_many_connections))
(cons
(case "New_point" % string None
(Tezos_data_encoding.Data_encoding.Tag 2)
(branch_encoding "new_point" % string
(obj1 (req None None "point" % string P2p_point.Id.encoding)))
(fun function_parameter =>
match function_parameter with
| New_point p => Some p
| _ => None
end) (fun p => New_point p))
(cons
(case "New_peer" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(branch_encoding "new_peer" % string
(obj1
(req None None "peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| New_peer p => Some p
| _ => None
end) (fun p => New_peer p))
(cons
(case "Incoming_connection" % string None
(Tezos_data_encoding.Data_encoding.Tag 4)
(branch_encoding "incoming_connection" % string
(obj1
(req None None "point" % string P2p_point.Id.encoding)))
(fun function_parameter =>
match function_parameter with
| Incoming_connection p => Some p
| _ => None
end) (fun p => Incoming_connection p))
(cons
(case "Outgoing_connection" % string None
(Tezos_data_encoding.Data_encoding.Tag 5)
(branch_encoding "outgoing_connection" % string
(obj1
(req None None "point" % string P2p_point.Id.encoding)))
(fun function_parameter =>
match function_parameter with
| Outgoing_connection p => Some p
| _ => None
end) (fun p => Outgoing_connection p))
(cons
(case "Authentication_failed" % string None
(Tezos_data_encoding.Data_encoding.Tag 6)
(branch_encoding "authentication_failed" % string
(obj1
(req None None "point" % string
P2p_point.Id.encoding)))
(fun function_parameter =>
match function_parameter with
| Authentication_failed p => Some p
| _ => None
end) (fun p => Authentication_failed p))
(cons
(case "Accepting_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 7)
(branch_encoding "accepting_request" % string
(obj3
(req None None "point" % string
P2p_point.Id.encoding)
(req None None "id_point" % string Id.encoding)
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Accepting_request p id_p g => Some (p, id_p, g)
| _ => None
end)
(fun function_parameter =>
let '(p, id_p, g) := function_parameter in
Accepting_request p id_p g))
(cons
(case "Rejecting_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 8)
(branch_encoding "rejecting_request" % string
(obj3
(req None None "point" % string
P2p_point.Id.encoding)
(req None None "id_point" % string Id.encoding)
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Rejecting_request p id_p g => Some (p, id_p, g)
| _ => None
end)
(fun function_parameter =>
let '(p, id_p, g) := function_parameter in
Rejecting_request p id_p g))
(cons
(case "Request_rejected" % string None
(Tezos_data_encoding.Data_encoding.Tag 9)
(branch_encoding "request_rejected" % string
(obj2
(req None None "point" % string
P2p_point.Id.encoding)
(opt None None "identity" % string
(tup2 Id.encoding P2p_peer_id.encoding))))
(fun function_parameter =>
match function_parameter with
| Request_rejected p id => Some (p, id)
| _ => None
end)
(fun function_parameter =>
let '(p, id) := function_parameter in
Request_rejected p id))
(cons
(case "Connection_established" % string None
(Tezos_data_encoding.Data_encoding.Tag 10)
(branch_encoding
"connection_established" % string
(obj2
(req None None "id_point" % string
Id.encoding)
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Connection_established id_p g =>
Some (id_p, g)
| _ => None
end)
(fun function_parameter =>
let '(id_p, g) := function_parameter in
Connection_established id_p g))
(cons
(case "Disconnection" % string None
(Tezos_data_encoding.Data_encoding.Tag 11)
(branch_encoding "disconnection" % string
(obj1
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Disconnection g => Some g
| _ => None
end) (fun g => Disconnection g))
(cons
(case "External_disconnection" % string None
(Tezos_data_encoding.Data_encoding.Tag 12)
(branch_encoding
"external_disconnection" % string
(obj1
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| External_disconnection g => Some g
| _ => None
end) (fun g => External_disconnection g))
(cons
(case "Gc_points" % string None
(Tezos_data_encoding.Data_encoding.Tag 13)
(branch_encoding "gc_points" % string
empty)
(fun function_parameter =>
match function_parameter with
| Gc_points => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Gc_points))
(cons
(case "Gc_peer_ids" % string None
(Tezos_data_encoding.Data_encoding.Tag
14)
(branch_encoding "gc_peer_ids" % string
empty)
(fun function_parameter =>
match function_parameter with
| Gc_peer_ids => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Gc_peer_ids))
(cons
(case "Swap_request_received" % string
None
(Tezos_data_encoding.Data_encoding.Tag
15)
(branch_encoding
"swap_request_received" % string
(obj1
(req None None "source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
|
Swap_request_received {|
source := source |} =>
Some source
| _ => None
end)
(fun source =>
Swap_request_received
{| source := source |}))
(cons
(case "Swap_ack_received" % string
None
(Tezos_data_encoding.Data_encoding.Tag
16)
(branch_encoding
"swap_ack_received" % string
(obj1
(req None None "source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
|
Swap_ack_received {|
source := source |} =>
Some source
| _ => None
end)
(fun source =>
Swap_ack_received
{| source := source |}))
(cons
(case "Swap_request_sent" % string
None
(Tezos_data_encoding.Data_encoding.Tag
17)
(branch_encoding
"swap_request_sent" % string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
|
Swap_request_sent {|
source := source |} =>
Some source
| _ => None
end)
(fun source =>
Swap_request_sent
{| source := source |}))
(cons
(case "Swap_ack_sent" % string
None
(Tezos_data_encoding.Data_encoding.Tag
18)
(branch_encoding
"swap_ack_sent" % string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
|
Swap_ack_sent {|
source := source |} =>
Some source
| _ => None
end)
(fun source =>
Swap_ack_sent
{| source := source |}))
(cons
(case
"Swap_request_ignored" %
string None
(Tezos_data_encoding.Data_encoding.Tag
19)
(branch_encoding
"swap_request_ignored" %
string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter
with
|
Swap_request_ignored {|
source := source |}
=> Some source
| _ => None
end)
(fun source =>
Swap_request_ignored
{| source := source |}))
(cons
(case "Swap_success" % string
None
(Tezos_data_encoding.Data_encoding.Tag
20)
(branch_encoding
"swap_success" % string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter
with
|
Swap_success {|
source := source
|} => Some source
| _ => None
end)
(fun source =>
Swap_success
{| source := source |}))
(cons
(case
"Swap_failure" % string
None
(Tezos_data_encoding.Data_encoding.Tag
21)
(branch_encoding
"swap_failure" % string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter
with
|
Swap_failure {|
source := source
|} => Some source
| _ => None
end)
(fun source =>
Swap_failure
{| source := source |}))
[]))))))))))))))))))))))).
End P2p_event.
src/lib_base/p2p_identity.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
peer_id : P2p_peer.Id.t;
public_key : Crypto_box.public_key;
secret_key : Crypto_box.secret_key;
proof_of_work_stamp : Crypto_box.nonce;
}
let encoding =
let open Data_encoding in
def
"p2p_identity"
~description:
"The identity of a peer. This includes cryptographic keys as well as a \
proof-of-work."
@@ conv
(fun {peer_id; public_key; secret_key; proof_of_work_stamp} ->
(Some peer_id, public_key, secret_key, proof_of_work_stamp))
(fun (peer_id_opt, public_key, secret_key, proof_of_work_stamp) ->
let peer_id =
match peer_id_opt with
| Some peer_id ->
peer_id
| None ->
Tezos_crypto.Crypto_box.hash public_key
in
{peer_id; public_key; secret_key; proof_of_work_stamp})
(obj4
(opt "peer_id" P2p_peer_id.encoding)
(req "public_key" Crypto_box.public_key_encoding)
(req "secret_key" Crypto_box.secret_key_encoding)
(req "proof_of_work_stamp" Crypto_box.nonce_encoding))
let generate_with_bound ?max target =
let (secret_key, public_key, peer_id) = Crypto_box.random_keypair () in
let proof_of_work_stamp =
Crypto_box.generate_proof_of_work ?max public_key target
in
{peer_id; public_key; secret_key; proof_of_work_stamp}
let generate target = generate_with_bound target
let () = Data_encoding.Registration.register encoding
src/lib_base/p2p_identity.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
peer_id : Tezos_base.P2p_peer.Id.t;
public_key : Tezos_crypto.Crypto_box.public_key;
secret_key : Tezos_crypto.Crypto_box.secret_key;
proof_of_work_stamp : Tezos_crypto.Crypto_box.nonce }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_identity" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The identity of a peer. This includes cryptographic keys as well as a proof-of-work."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
peer_id := peer_id;
public_key := public_key;
secret_key := secret_key;
proof_of_work_stamp := proof_of_work_stamp
|} := function_parameter in
((Some peer_id), public_key, secret_key, proof_of_work_stamp))
(fun function_parameter =>
let '(peer_id_opt, public_key, secret_key, proof_of_work_stamp) :=
function_parameter in
let peer_id :=
match peer_id_opt with
| Some peer_id => peer_id
| None => Tezos_crypto.Crypto_box.hash public_key
end in
{| peer_id := peer_id; public_key := public_key;
secret_key := secret_key; proof_of_work_stamp := proof_of_work_stamp
|}) None
(obj4 (opt None None "peer_id" % string P2p_peer_id.encoding)
(req None None "public_key" % string Crypto_box.public_key_encoding)
(req None None "secret_key" % string Crypto_box.secret_key_encoding)
(req None None "proof_of_work_stamp" % string Crypto_box.nonce_encoding))).
Definition generate_with_bound
(max : option Z) (target : Tezos_crypto.Crypto_box.target) : t :=
let '(secret_key, public_key, peer_id) := Crypto_box.random_keypair tt in
let proof_of_work_stamp :=
Crypto_box.generate_proof_of_work max public_key target in
{| peer_id := peer_id; public_key := public_key; secret_key := secret_key;
proof_of_work_stamp := proof_of_work_stamp |}.
Definition generate (target : Tezos_crypto.Crypto_box.target) : t :=
generate_with_bound None target.
src/lib_base/p2p_peer.ml 37 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Id = P2p_peer_id
module Table = Id.Table
module Error_table = Id.Error_table
module Map = Id.Map
module Set = Id.Set
module Filter = struct
type t = Accepted | Running | Disconnected
let rpc_arg =
RPC_arg.make
~name:"p2p.point.state_filter"
~destruct:(function
| "accepted" ->
Ok Accepted
| "running" ->
Ok Running
| "disconnected" ->
Ok Disconnected
| s ->
Error (Format.asprintf "Invalid state: %s" s))
~construct:(function
| Accepted ->
"accepted"
| Running ->
"running"
| Disconnected ->
"disconnected")
()
end
module State = struct
type t = Accepted | Running | Disconnected
let pp_digram ppf = function
| Accepted ->
Format.fprintf ppf "â"
| Running ->
Format.fprintf ppf "â"
| Disconnected ->
Format.fprintf ppf "â"
let encoding =
let open Data_encoding in
def
"p2p_peer.state"
~description:
"The state a peer connection can be in: accepted (when the connection \
is being established), running (when the connection is already \
established), disconnected (otherwise)."
@@ string_enum
[ ("accepted", Accepted);
("running", Running);
("disconnected", Disconnected) ]
let raw_filter (f : Filter.t) (s : t) =
match (f, s) with
| (Accepted, Accepted) ->
true
| (Accepted, (Running | Disconnected))
| ((Running | Disconnected), Accepted) ->
false
| (Running, Running) ->
true
| (Disconnected, Disconnected) ->
true
| (Running, Disconnected) | (Disconnected, Running) ->
false
let filter filters state = List.exists (fun f -> raw_filter f state) filters
end
module Info = struct
type ('peer_meta, 'conn_meta) t = {
score : float;
trusted : bool;
conn_metadata : 'conn_meta option;
peer_metadata : 'peer_meta;
state : State.t;
id_point : P2p_connection.Id.t option;
stat : P2p_stat.t;
last_failed_connection : (P2p_connection.Id.t * Time.System.t) option;
last_rejected_connection : (P2p_connection.Id.t * Time.System.t) option;
last_established_connection : (P2p_connection.Id.t * Time.System.t) option;
last_disconnection : (P2p_connection.Id.t * Time.System.t) option;
last_seen : (P2p_connection.Id.t * Time.System.t) option;
last_miss : (P2p_connection.Id.t * Time.System.t) option;
}
let encoding peer_metadata_encoding conn_metadata_encoding =
let open Data_encoding in
conv
(fun { score;
trusted;
conn_metadata;
peer_metadata;
state;
id_point;
stat;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
last_seen;
last_miss } ->
( (score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
( last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection,
last_seen,
last_miss ) ))
(fun ( ( score,
trusted,
conn_metadata,
peer_metadata,
state,
id_point,
stat ),
( last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection,
last_seen,
last_miss ) ) ->
{
score;
trusted;
conn_metadata;
peer_metadata;
state;
id_point;
stat;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
last_seen;
last_miss;
})
(merge_objs
(obj7
(req "score" float)
(req "trusted" bool)
(opt "conn_metadata" conn_metadata_encoding)
(req "peer_metadata" peer_metadata_encoding)
(req "state" State.encoding)
(opt "reachable_at" P2p_connection.Id.encoding)
(req "stat" P2p_stat.encoding))
(obj6
(opt
"last_failed_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_rejected_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_established_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_disconnection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_seen"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_miss"
(tup2 P2p_connection.Id.encoding Time.System.encoding))))
end
module Pool_event = struct
type kind =
| Accepting_request
| Rejecting_request
| Request_rejected
| Connection_established
| Disconnection
| External_disconnection
let kind_encoding =
Data_encoding.string_enum
[ ("incoming_request", Accepting_request);
("rejecting_request", Rejecting_request);
("request_rejected", Request_rejected);
("connection_established", Connection_established);
("disconnection", Disconnection);
("external_disconnection", External_disconnection) ]
type t = {
kind : kind;
timestamp : Time.System.t;
point : P2p_connection.Id.t;
}
let encoding =
let open Data_encoding in
def
"p2p_peer.pool_event"
~description:
"An event that may happen during maintenance of and other operations \
on the connection to a specific peer."
@@ conv
(fun {kind; timestamp; point = (addr, port)} ->
(kind, timestamp, addr, port))
(fun (kind, timestamp, addr, port) ->
{kind; timestamp; point = (addr, port)})
(obj4
(req "kind" kind_encoding)
(req "timestamp" Time.System.encoding)
(req "addr" P2p_addr.encoding)
(opt "port" uint16))
end
let () =
Data_encoding.Registration.register ~pp:State.pp_digram State.encoding ;
Data_encoding.Registration.register Pool_event.encoding
src/lib_base/p2p_peer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Filter.
Inductive t : Type :=
| Accepted : t
| Running : t
| Disconnected : t.
Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
RPC_arg.make None "p2p.point.state_filter" % string
(fun function_parameter =>
match function_parameter with
| "accepted" % string => Stdlib.Ok Accepted
| "running" % string => Stdlib.Ok Running
| "disconnected" % string => Stdlib.Ok Disconnected
| s =>
Stdlib.Error
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid state: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Invalid state: %s" % string) s)
end)
(fun function_parameter =>
match function_parameter with
| Accepted => "accepted" % string
| Running => "running" % string
| Disconnected => "disconnected" % string
end) tt.
End Filter.
Module State.
Inductive t : Type :=
| Accepted : t
| Running : t
| Disconnected : t.
Definition pp_digram (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Accepted =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚎" % string
CamlinternalFormatBasics.End_of_format) "⚎" % string)
| Running =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚌" % string
CamlinternalFormatBasics.End_of_format) "⚌" % string)
| Disconnected =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚏" % string
CamlinternalFormatBasics.End_of_format) "⚏" % string)
end.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_peer.state" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The state a peer connection can be in: accepted (when the connection is being established), running (when the connection is already established), disconnected (otherwise)."
% string) in
fun eta => arg None eta)
(string_enum
(cons ("accepted" % string, Accepted)
(cons ("running" % string, Running)
(cons ("disconnected" % string, Disconnected) [])))).
Definition raw_filter (f : Filter.t) (s : t) : bool :=
match (f, s) with
| (Filter.Accepted, Accepted) => true
|
(Filter.Accepted, Running | Disconnected) |
(Filter.Running | Filter.Disconnected, Accepted) => false
| (Filter.Running, Running) => true
| (Filter.Disconnected, Disconnected) => true
| (Filter.Running, Disconnected) | (Filter.Disconnected, Running) => false
end.
Definition filter (filters : list Filter.t) (state : t) : bool :=
Stdlib.List._exists (fun f => raw_filter f state) filters.
End State.
Module Info.
Record t {peer_meta conn_meta : Type} := {
score : Z;
trusted : bool;
conn_metadata : option conn_meta;
peer_metadata : peer_meta;
state : State.t;
id_point : option Tezos_base.P2p_connection.Id.t;
stat : Tezos_base.P2p_stat.t;
last_failed_connection :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_rejected_connection :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_established_connection :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_disconnection :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_seen :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_miss :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t) }.
Arguments t : clear implicits.
Definition encoding {A B : Type}
(peer_metadata_encoding : Tezos_data_encoding.Data_encoding.encoding A)
(conn_metadata_encoding : Tezos_data_encoding.Data_encoding.encoding B)
: Tezos_data_encoding.Data_encoding.encoding (t A B) :=
conv
(fun function_parameter =>
let '{|
score := score;
trusted := trusted;
conn_metadata := conn_metadata;
peer_metadata := peer_metadata;
state := state;
id_point := id_point;
stat := stat;
last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection;
last_seen := last_seen;
last_miss := last_miss
|} := function_parameter in
((score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
(last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection, last_seen,
last_miss)))
(fun function_parameter =>
let
'((score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
(last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection, last_seen,
last_miss)) := function_parameter in
{| score := score; trusted := trusted; conn_metadata := conn_metadata;
peer_metadata := peer_metadata; state := state; id_point := id_point;
stat := stat; last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection; last_seen := last_seen;
last_miss := last_miss |}) None
(merge_objs
(obj7 (req None None "score" % string float)
(req None None "trusted" % string bool)
(opt None None "conn_metadata" % string conn_metadata_encoding)
(req None None "peer_metadata" % string peer_metadata_encoding)
(req None None "state" % string State.encoding)
(opt None None "reachable_at" % string P2p_connection.Id.encoding)
(req None None "stat" % string P2p_stat.encoding))
(obj6
(opt None None "last_failed_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_rejected_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_established_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_disconnection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_seen" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_miss" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding)))).
End Info.
Module Pool_event.
Inductive kind : Type :=
| Accepting_request : kind
| Rejecting_request : kind
| Request_rejected : kind
| Connection_established : kind
| Disconnection : kind
| External_disconnection : kind.
Definition kind_encoding : Tezos_data_encoding.Data_encoding.encoding kind :=
Data_encoding.string_enum
(cons ("incoming_request" % string, Accepting_request)
(cons ("rejecting_request" % string, Rejecting_request)
(cons ("request_rejected" % string, Request_rejected)
(cons ("connection_established" % string, Connection_established)
(cons ("disconnection" % string, Disconnection)
(cons
("external_disconnection" % string, External_disconnection) [])))))).
Record t := {
kind : kind;
timestamp : Tezos_base.Time.System.t;
point : Tezos_base.P2p_connection.Id.t }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_peer.pool_event" % string
(* ❌ expected an argument *)
expected_argument
(Some
"An event that may happen during maintenance of and other operations on the connection to a specific peer."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
kind := kind; timestamp := timestamp; point := (addr, port) |} :=
function_parameter in
(kind, timestamp, addr, port))
(fun function_parameter =>
let '(kind, timestamp, addr, port) := function_parameter in
{| kind := kind; timestamp := timestamp; point := (addr, port) |})
None
(obj4 (req None None "kind" % string kind_encoding)
(req None None "timestamp" % string Time.System.encoding)
(req None None "addr" % string P2p_addr.encoding)
(opt None None "port" % string uint16))).
End Pool_event.
src/lib_base/p2p_peer_id.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Crypto_box.Public_key_hash
let rpc_arg =
RPC_arg.like
rpc_arg
~descr:"A cryptographic node identity (Base58Check-encoded)"
"peer_id"
let pp_source ppf = function
| None ->
()
| Some peer ->
Format.fprintf ppf " from peer %a" pp peer
module Logging = struct
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "node.distributed_db.p2p_peer_id"
end)
let mk_tag pp = Tag.def ~doc:"P2P peer ID" "p2p_peer_id" pp
let tag = mk_tag pp_short
let tag_opt =
mk_tag (fun ppf -> function None -> () | Some peer -> pp_short ppf peer)
let tag_source =
Tag.def
~doc:"Peer which provided information"
"p2p_peer_id_source"
pp_source
end
src/lib_base/p2p_peer_id.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
RPC_arg.like rpc_arg
(Some "A cryptographic node identity (Base58Check-encoded)" % string)
"peer_id" % string.
Definition pp_source
(ppf : Stdlib.Format.formatter) (function_parameter : option t) : unit :=
match function_parameter with
| None => tt
| Some peer =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal " from peer " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
" from peer %a" % string) pp peer
end.
Module Logging.
(* ❌ Structure item `include` not handled. *)
include
Definition mk_tag {A : Type} (pp : Stdlib.Format.formatter -> A -> unit)
: Tag.def A :=
Tag.def (Some "P2P peer ID" % string) "p2p_peer_id" % string pp.
Definition tag : Tag.def t := mk_tag pp_short.
Definition tag_opt : Tag.def (option t) :=
mk_tag
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None => tt
| Some peer => pp_short ppf peer
end).
Definition tag_source : Tag.def (option t) :=
Tag.def (Some "Peer which provided information" % string)
"p2p_peer_id_source" % string pp_source.
End Logging.
src/lib_base/p2p_point.ml 33 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Id = struct
(* A net point (address x port). *)
type t = P2p_addr.t * P2p_addr.port
let compare (a1, p1) (a2, p2) =
match Ipaddr.V6.compare a1 a2 with 0 -> p1 - p2 | x -> x
let equal p1 p2 = compare p1 p2 = 0
let hash = Hashtbl.hash
let pp ppf (addr, port) =
match Ipaddr.v4_of_v6 addr with
| Some addr ->
Format.fprintf ppf "%a:%d" Ipaddr.V4.pp addr port
| None ->
Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp addr port
let pp_opt ppf = function
| None ->
Format.pp_print_string ppf "none"
| Some point ->
pp ppf point
let pp_list ppf point_list =
Format.pp_print_list ~pp_sep:Format.pp_print_space pp ppf point_list
let is_local (addr, _) = Ipaddr.V6.is_private addr
let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
let check_port port =
if
TzString.mem_char port '[' || TzString.mem_char port ']'
|| TzString.mem_char port ':'
then invalid_arg "Utils.parse_addr_port (invalid character in port)"
let parse_addr_port s =
let len = String.length s in
if len = 0 then ("", "")
else if s.[0] = '[' then (
(* inline IPv6 *)
match String.rindex_opt s ']' with
| None ->
invalid_arg "Utils.parse_addr_port (missing ']')"
| Some pos ->
let addr = String.sub s 1 (pos - 1) in
let port =
if pos = len - 1 then ""
else if s.[pos + 1] <> ':' then
invalid_arg "Utils.parse_addr_port (unexpected char after ']')"
else String.sub s (pos + 2) (len - pos - 2)
in
check_port port ; (addr, port) )
else
match String.rindex_opt s ']' with
| Some _pos ->
invalid_arg "Utils.parse_addr_port (unexpected char ']')"
| None -> (
match String.index s ':' with
| exception _ ->
(s, "")
| pos -> (
match String.index_from s (pos + 1) ':' with
| exception _ ->
let addr = String.sub s 0 pos in
let port = String.sub s (pos + 1) (len - pos - 1) in
check_port port ; (addr, port)
| _pos ->
invalid_arg
"Utils.parse_addr_port: IPv6 addresses must be bracketed" ) )
let of_string_exn ?default_port str =
let (addr, port) = parse_addr_port str in
let port =
if port = "" then
Option.unopt_exn
(Invalid_argument "P2p_point.of_string_exn: no port")
default_port
else int_of_string port
in
if port < 0 && port > (1 lsl 16) - 1 then
invalid_arg "port must be between 0 and 65535" ;
match Ipaddr.of_string_exn addr with
| V4 addr ->
(Ipaddr.v6_of_v4 addr, port)
| V6 addr ->
(addr, port)
let of_string ?default_port str =
try Ok (of_string_exn ?default_port str) with
| Invalid_argument s ->
Error s
| Failure s ->
Error s
| _ ->
Error "P2p_point.of_string"
let to_string saddr = Format.asprintf "%a" pp saddr
let encoding =
let open Data_encoding in
def "p2p_point.id" ~description:"Identifier for a peer point"
@@ conv to_string of_string_exn string
let rpc_arg =
RPC_arg.make
~name:"point"
~descr:"A network point (ipv4:port or [ipv6]:port)."
~destruct:of_string
~construct:to_string
()
end
module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)
module Filter = struct
type t = Requested | Accepted | Running | Disconnected
let rpc_arg =
RPC_arg.make
~name:"p2p.point.state_filter"
~destruct:(function
| "requested" ->
Ok Requested
| "accepted" ->
Ok Accepted
| "running" ->
Ok Running
| "disconnected" ->
Ok Disconnected
| s ->
Error (Format.asprintf "Invalid state: %s" s))
~construct:(function
| Requested ->
"requested"
| Accepted ->
"accepted"
| Running ->
"running"
| Disconnected ->
"disconnected")
()
end
module State = struct
type t =
| Requested
| Accepted of P2p_peer_id.t
| Running of P2p_peer_id.t
| Disconnected
let of_p2p_peer_id = function
| Requested ->
None
| Accepted pi ->
Some pi
| Running pi ->
Some pi
| Disconnected ->
None
let of_peerid_state state pi =
match (state, pi) with
| (Requested, _) ->
Requested
| (Accepted _, Some pi) ->
Accepted pi
| (Running _, Some pi) ->
Running pi
| (Disconnected, _) ->
Disconnected
| _ ->
invalid_arg "state_of_state_peerid"
let pp_digram ppf = function
| Requested ->
Format.fprintf ppf "â"
| Accepted _ ->
Format.fprintf ppf "â"
| Running _ ->
Format.fprintf ppf "â"
| Disconnected ->
Format.fprintf ppf "â"
let encoding =
let open Data_encoding in
let branch_encoding name obj =
conv
(fun x -> ((), x))
(fun ((), x) -> x)
(merge_objs (obj1 (req "event_kind" (constant name))) obj)
in
def
"p2p_point.state"
~description:
"The state a connection to a peer point can be in: requested \
(connection open from here), accepted (handshake), running \
(connection already established), disconnected (no connection)."
@@ union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Requested"
(branch_encoding "requested" empty)
(function Requested -> Some () | _ -> None)
(fun () -> Requested);
case
(Tag 1)
~title:"Accepted"
(branch_encoding
"accepted"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Accepted p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Accepted p2p_peer_id);
case
(Tag 2)
~title:"Running"
(branch_encoding
"running"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Running p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Running p2p_peer_id);
case
(Tag 3)
~title:"Disconnected"
(branch_encoding "disconnected" empty)
(function Disconnected -> Some () | _ -> None)
(fun () -> Disconnected) ]
let raw_filter (f : Filter.t) (s : t) =
match (f, s) with
| (Requested, Requested) ->
true
| (Requested, (Accepted _ | Running _ | Disconnected))
| ((Accepted | Running | Disconnected), Requested) ->
false
| (Accepted, Accepted _) ->
true
| (Accepted, (Running _ | Disconnected))
| ((Running | Disconnected), Accepted _) ->
false
| (Running, Running _) ->
true
| (Disconnected, Disconnected) ->
true
| (Running, Disconnected) | (Disconnected, Running _) ->
false
let filter filters state = List.exists (fun f -> raw_filter f state) filters
end
module Info = struct
type t = {
trusted : bool;
greylisted_until : Time.System.t;
state : State.t;
last_failed_connection : Time.System.t option;
last_rejected_connection : (P2p_peer_id.t * Time.System.t) option;
last_established_connection : (P2p_peer_id.t * Time.System.t) option;
last_disconnection : (P2p_peer_id.t * Time.System.t) option;
last_seen : (P2p_peer_id.t * Time.System.t) option;
last_miss : Time.System.t option;
}
let encoding =
let open Data_encoding in
def
"p2p_point.info"
~description:
"Information about a peer point. Includes flags, state, and records \
about past events."
@@ conv
(fun { trusted;
greylisted_until;
state;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
last_seen;
last_miss } ->
let p2p_peer_id = State.of_p2p_peer_id state in
( trusted,
greylisted_until,
state,
p2p_peer_id,
last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection,
last_seen,
last_miss ))
(fun ( trusted,
greylisted_until,
state,
p2p_peer_id,
last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection,
last_seen,
last_miss ) ->
let state = State.of_peerid_state state p2p_peer_id in
{
trusted;
greylisted_until;
state;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
last_seen;
last_miss;
})
(obj10
(req "trusted" bool)
(dft "greylisted_until" Time.System.encoding Time.System.epoch)
(req "state" State.encoding)
(opt "p2p_peer_id" P2p_peer_id.encoding)
(opt "last_failed_connection" Time.System.encoding)
(opt
"last_rejected_connection"
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt
"last_established_connection"
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt
"last_disconnection"
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt "last_seen" (tup2 P2p_peer_id.encoding Time.System.encoding))
(opt "last_miss" Time.System.encoding))
end
module Pool_event = struct
type kind =
| Outgoing_request
| Accepting_request of P2p_peer_id.t
| Rejecting_request of P2p_peer_id.t
| Request_rejected of P2p_peer_id.t option
| Connection_established of P2p_peer_id.t
| Disconnection of P2p_peer_id.t
| External_disconnection of P2p_peer_id.t
let kind_encoding =
let open Data_encoding in
let branch_encoding name obj =
conv
(fun x -> ((), x))
(fun ((), x) -> x)
(merge_objs (obj1 (req "event_kind" (constant name))) obj)
in
union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Outgoing_request"
(branch_encoding "outgoing_request" empty)
(function Outgoing_request -> Some () | _ -> None)
(fun () -> Outgoing_request);
case
(Tag 1)
~title:"Accepting_request"
(branch_encoding
"accepting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Accepting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Accepting_request p2p_peer_id);
case
(Tag 2)
~title:"Rejecting_request"
(branch_encoding
"rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Rejecting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Rejecting_request p2p_peer_id);
case
(Tag 3)
~title:"Rejecting_rejected"
(branch_encoding
"request_rejected"
(obj1 (opt "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Request_rejected p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Request_rejected p2p_peer_id);
case
(Tag 4)
~title:"Connection_established"
(branch_encoding
"rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Connection_established p2p_peer_id ->
Some p2p_peer_id
| _ ->
None)
(fun p2p_peer_id -> Connection_established p2p_peer_id);
case
(Tag 5)
~title:"Disconnection"
(branch_encoding
"rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Disconnection p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Disconnection p2p_peer_id);
case
(Tag 6)
~title:"External_disconnection"
(branch_encoding
"rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| External_disconnection p2p_peer_id ->
Some p2p_peer_id
| _ ->
None)
(fun p2p_peer_id -> External_disconnection p2p_peer_id) ]
type t = kind Time.System.stamped
let encoding =
Data_encoding.def
"p2p_point.pool_event"
~description:
"Events happening during maintenance of and operations on a peer \
point pool (such as connections, disconnections, connection \
requests)."
@@ Time.System.stamped_encoding kind_encoding
end
let () =
Data_encoding.Registration.register ~pp:Id.pp Id.encoding ;
Data_encoding.Registration.register ~pp:State.pp_digram State.encoding ;
Data_encoding.Registration.register Info.encoding ;
Data_encoding.Registration.register Pool_event.encoding
src/lib_base/p2p_point.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Id.
Definition t := Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port.
Definition compare (function_parameter : Ipaddr.V6.t * Z)
: (Ipaddr.V6.t * Z) -> Z :=
let '(a1, p1) := function_parameter in
fun function_parameter =>
let '(a2, p2) := function_parameter in
match Ipaddr.V6.compare a1 a2 with
| 0 => Z.sub p1 p2
| x => x
end.
Definition equal (p1 : Ipaddr.V6.t * Z) (p2 : Ipaddr.V6.t * Z) : bool :=
equiv_decb (compare p1 p2) 0.
Definition hash {A : Type} : A -> Z := Hashtbl.hash.
Definition pp
(ppf : Stdlib.Format.formatter) (function_parameter : Ipaddr.V6.t * Z)
: unit :=
let '(addr, port) := function_parameter in
match Ipaddr.v4_of_v6 addr with
| Some addr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%a:%d" % string)
Ipaddr.V4.pp addr port
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "]:" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))) "[%a]:%d" % string)
Ipaddr.V6.pp addr port
end.
Definition pp_opt
(ppf : Stdlib.Format.formatter)
(function_parameter : option (Ipaddr.V6.t * Z)) : unit :=
match function_parameter with
| None => Format.pp_print_string ppf "none" % string
| Some point => pp ppf point
end.
Definition pp_list
(ppf : Stdlib.Format.formatter) (point_list : list (Ipaddr.V6.t * Z))
: unit :=
Format.pp_print_list (Some Format.pp_print_space) pp ppf point_list.
Definition is_local {A : Type} (function_parameter : Ipaddr.V6.t * A)
: bool :=
let '(addr, _) := function_parameter in
Ipaddr.V6.is_private addr.
Definition is_global {A : Type} (function_parameter : Ipaddr.V6.t * A)
: bool :=
let '(addr, _) := function_parameter in
apply negb (Ipaddr.V6.is_private addr).
Definition check_port (port : string) : unit :=
if
orb (TzString.mem_char port "[" % char)
(orb (TzString.mem_char port "]" % char)
(TzString.mem_char port ":" % char)) then
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port (invalid character in port)" % string
else
tt.
Definition parse_addr_port (s : string) : string * string :=
let len := OCaml.String.length s in
if equiv_decb len 0 then
("" % string, "" % string)
else
if equiv_decb (Stdlib.String.get s 0) "[" % char then
match Stdlib.String.rindex_opt s "]" % char with
| None =>
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port (missing ']')" % string
| Some pos =>
let addr := Stdlib.String.sub s 1 (Z.sub pos 1) in
let port :=
if equiv_decb pos (Z.sub len 1) then
"" % string
else
if nequiv_decb (Stdlib.String.get s (Z.add pos 1)) ":" % char then
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port (unexpected char after ']')" % string
else
Stdlib.String.sub s (Z.add pos 2) (Z.sub (Z.sub len pos) 2) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_port port in
(addr, port)
end
else
match Stdlib.String.rindex_opt s "]" % char with
| Some _pos =>
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port (unexpected char ']')" % string
| None =>
let 'pos := Stdlib.String.index s ":" % char in
let '_pos := Stdlib.String.index_from s (Z.add pos 1) ":" % char in
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port: IPv6 addresses must be bracketed" % string
end.
Definition of_string_exn (default_port : option Z) (str : string)
: Ipaddr.V6.t * Z :=
let '(addr, port) := parse_addr_port str in
let port :=
if equiv_decb port "" % string then
Option.unopt_exn
(OCaml.Invalid_argument "P2p_point.of_string_exn: no port" % string)
default_port
else
OCaml.Stdlib.int_of_string port in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
andb (OCaml.Stdlib.lt port 0)
(OCaml.Stdlib.gt port (Z.sub (Z.shiftl 1 16) 1)) then
OCaml.Stdlib.invalid_arg "port must be between 0 and 65535" % string
else
tt in
match Ipaddr.of_string_exn addr with
| Ipaddr.V4 addr => ((Ipaddr.v6_of_v4 addr), port)
| Ipaddr.V6 addr => (addr, port)
end.
Definition of_string (default_port : option Z) (str : string)
: sum (Ipaddr.V6.t * Z) string :=
(* ❌ Try-with are not handled *)
try (Stdlib.Ok (of_string_exn default_port str)).
Definition to_string (saddr : Ipaddr.V6.t * Z) : string :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp saddr.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding (Ipaddr.V6.t * Z) :=
apply
(let arg :=
def "p2p_point.id" % string
(* ❌ expected an argument *)
expected_argument (Some "Identifier for a peer point" % string) in
fun eta => arg None eta)
(conv to_string
(let arg := of_string_exn in
fun eta => arg None eta) None string).
Definition rpc_arg : Tezos_rpc.RPC_arg.arg (Ipaddr.V6.t * Z) :=
RPC_arg.make (Some "A network point (ipv4:port or [ipv6]:port)." % string)
"point" % string
(let arg := of_string in
fun eta => arg None eta) to_string tt.
End Id.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module Filter.
Inductive t : Type :=
| Requested : t
| Accepted : t
| Running : t
| Disconnected : t.
Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
RPC_arg.make None "p2p.point.state_filter" % string
(fun function_parameter =>
match function_parameter with
| "requested" % string => Stdlib.Ok Requested
| "accepted" % string => Stdlib.Ok Accepted
| "running" % string => Stdlib.Ok Running
| "disconnected" % string => Stdlib.Ok Disconnected
| s =>
Stdlib.Error
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid state: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Invalid state: %s" % string) s)
end)
(fun function_parameter =>
match function_parameter with
| Requested => "requested" % string
| Accepted => "accepted" % string
| Running => "running" % string
| Disconnected => "disconnected" % string
end) tt.
End Filter.
Module State.
Inductive t : Type :=
| Requested : t
| Accepted : Tezos_base.P2p_peer_id.t -> t
| Running : Tezos_base.P2p_peer_id.t -> t
| Disconnected : t.
Definition of_p2p_peer_id (function_parameter : t)
: option Tezos_base.P2p_peer_id.t :=
match function_parameter with
| Requested => None
| Accepted pi => Some pi
| Running pi => Some pi
| Disconnected => None
end.
Definition of_peerid_state (state : t) (pi : option Tezos_base.P2p_peer_id.t)
: t :=
match (state, pi) with
| (Requested, _) => Requested
| (Accepted _, Some pi) => Accepted pi
| (Running _, Some pi) => Running pi
| (Disconnected, _) => Disconnected
| _ => OCaml.Stdlib.invalid_arg "state_of_state_peerid" % string
end.
Definition pp_digram (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Requested =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚎" % string
CamlinternalFormatBasics.End_of_format) "⚎" % string)
| Accepted _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚍" % string
CamlinternalFormatBasics.End_of_format) "⚍" % string)
| Running _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚌" % string
CamlinternalFormatBasics.End_of_format) "⚌" % string)
| Disconnected =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚏" % string
CamlinternalFormatBasics.End_of_format) "⚏" % string)
end.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
let branch_encoding {A : Type}
(name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding A :=
conv (fun x => (tt, x))
(fun function_parameter =>
let '(tt, x) := function_parameter in
x) None
(merge_objs (obj1 (req None None "event_kind" % string (constant name)))
obj) in
apply
(let arg :=
def "p2p_point.state" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The state a connection to a peer point can be in: requested (connection open from here), accepted (handshake), running (connection already established), disconnected (no connection)."
% string) in
fun eta => arg None eta)
(union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Requested" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(branch_encoding "requested" % string empty)
(fun function_parameter =>
match function_parameter with
| Requested => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Requested))
(cons
(case "Accepted" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(branch_encoding "accepted" % string
(obj1
(req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Accepted p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Accepted p2p_peer_id))
(cons
(case "Running" % string None
(Tezos_data_encoding.Data_encoding.Tag 2)
(branch_encoding "running" % string
(obj1
(req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Running p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Running p2p_peer_id))
(cons
(case "Disconnected" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(branch_encoding "disconnected" % string empty)
(fun function_parameter =>
match function_parameter with
| Disconnected => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Disconnected)) []))))).
Definition raw_filter (f : Filter.t) (s : t) : bool :=
match (f, s) with
| (Filter.Requested, Requested) => true
|
(Filter.Requested, Accepted _ | Running _ | Disconnected) |
(Filter.Accepted | Filter.Running | Filter.Disconnected, Requested) =>
false
| (Filter.Accepted, Accepted _) => true
|
(Filter.Accepted, Running _ | Disconnected) |
(Filter.Running | Filter.Disconnected, Accepted _) => false
| (Filter.Running, Running _) => true
| (Filter.Disconnected, Disconnected) => true
| (Filter.Running, Disconnected) | (Filter.Disconnected, Running _) => false
end.
Definition filter (filters : list Filter.t) (state : t) : bool :=
Stdlib.List._exists (fun f => raw_filter f state) filters.
End State.
Module Info.
Record t := {
trusted : bool;
greylisted_until : Tezos_base.Time.System.t;
state : State.t;
last_failed_connection : option Tezos_base.Time.System.t;
last_rejected_connection :
option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
last_established_connection :
option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
last_disconnection :
option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
last_seen : option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
last_miss : option Tezos_base.Time.System.t }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_point.info" % string
(* ❌ expected an argument *)
expected_argument
(Some
"Information about a peer point. Includes flags, state, and records about past events."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
trusted := trusted;
greylisted_until := greylisted_until;
state := state;
last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection;
last_seen := last_seen;
last_miss := last_miss
|} := function_parameter in
let p2p_peer_id := State.of_p2p_peer_id state in
(trusted, greylisted_until, state, p2p_peer_id,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection, last_seen,
last_miss))
(fun function_parameter =>
let
'(trusted, greylisted_until, state, p2p_peer_id,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection, last_seen,
last_miss) := function_parameter in
let state := State.of_peerid_state state p2p_peer_id in
{| trusted := trusted; greylisted_until := greylisted_until;
state := state; last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection; last_seen := last_seen;
last_miss := last_miss |}) None
(obj10 (req None None "trusted" % string bool)
(dft None None "greylisted_until" % string Time.System.encoding
Time.System.epoch) (req None None "state" % string State.encoding)
(opt None None "p2p_peer_id" % string P2p_peer_id.encoding)
(opt None None "last_failed_connection" % string Time.System.encoding)
(opt None None "last_rejected_connection" % string
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt None None "last_established_connection" % string
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt None None "last_disconnection" % string
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt None None "last_seen" % string
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt None None "last_miss" % string Time.System.encoding))).
End Info.
Module Pool_event.
Inductive kind : Type :=
| Outgoing_request : kind
| Accepting_request : Tezos_base.P2p_peer_id.t -> kind
| Rejecting_request : Tezos_base.P2p_peer_id.t -> kind
| Request_rejected : (option Tezos_base.P2p_peer_id.t) -> kind
| Connection_established : Tezos_base.P2p_peer_id.t -> kind
| Disconnection : Tezos_base.P2p_peer_id.t -> kind
| External_disconnection : Tezos_base.P2p_peer_id.t -> kind.
Definition kind_encoding : Tezos_data_encoding.Data_encoding.encoding kind :=
let branch_encoding {A : Type}
(name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding A :=
conv (fun x => (tt, x))
(fun function_parameter =>
let '(tt, x) := function_parameter in
x) None
(merge_objs (obj1 (req None None "event_kind" % string (constant name)))
obj) in
union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Outgoing_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(branch_encoding "outgoing_request" % string empty)
(fun function_parameter =>
match function_parameter with
| Outgoing_request => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Outgoing_request))
(cons
(case "Accepting_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(branch_encoding "accepting_request" % string
(obj1 (req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Accepting_request p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Accepting_request p2p_peer_id))
(cons
(case "Rejecting_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 2)
(branch_encoding "rejecting_request" % string
(obj1
(req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Rejecting_request p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Rejecting_request p2p_peer_id))
(cons
(case "Rejecting_rejected" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(branch_encoding "request_rejected" % string
(obj1
(opt None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Request_rejected p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Request_rejected p2p_peer_id))
(cons
(case "Connection_established" % string None
(Tezos_data_encoding.Data_encoding.Tag 4)
(branch_encoding "rejecting_request" % string
(obj1
(req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Connection_established p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Connection_established p2p_peer_id))
(cons
(case "Disconnection" % string None
(Tezos_data_encoding.Data_encoding.Tag 5)
(branch_encoding "rejecting_request" % string
(obj1
(req None None "p2p_peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Disconnection p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Disconnection p2p_peer_id))
(cons
(case "External_disconnection" % string None
(Tezos_data_encoding.Data_encoding.Tag 6)
(branch_encoding "rejecting_request" % string
(obj1
(req None None "p2p_peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| External_disconnection p2p_peer_id => Some p2p_peer_id
| _ => None
end)
(fun p2p_peer_id => External_disconnection p2p_peer_id))
[]))))))).
Definition t := Tezos_base.Time.System.stamped kind.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_base.Time.System.stamped kind) :=
apply
(let arg :=
Data_encoding.def "p2p_point.pool_event" % string
(* ❌ expected an argument *)
expected_argument
(Some
"Events happening during maintenance of and operations on a peer point pool (such as connections, disconnections, connection requests)."
% string) in
fun eta => arg None eta) (Time.System.stamped_encoding kind_encoding).
End Pool_event.
src/lib_base/p2p_stat.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
total_sent : int64;
total_recv : int64;
current_inflow : int;
current_outflow : int;
}
let empty =
{total_sent = 0L; total_recv = 0L; current_inflow = 0; current_outflow = 0}
let print_size ppf sz =
let ratio n = float_of_int sz /. float_of_int (1 lsl n) in
if sz < 1 lsl 10 then Format.fprintf ppf "%d B" sz
else if sz < 1 lsl 20 then Format.fprintf ppf "%.2f kiB" (ratio 10)
else Format.fprintf ppf "%.2f MiB" (ratio 20)
let print_size64 ppf sz =
let open Int64 in
let ratio n = to_float sz /. float_of_int (1 lsl n) in
if sz < shift_left 1L 10 then Format.fprintf ppf "%Ld B" sz
else if sz < shift_left 1L 20 then Format.fprintf ppf "%.2f kiB" (ratio 10)
else if sz < shift_left 1L 30 then Format.fprintf ppf "%.2f MiB" (ratio 20)
else if sz < shift_left 1L 40 then Format.fprintf ppf "%.2f GiB" (ratio 30)
else Format.fprintf ppf "%.2f TiB" (ratio 40)
let pp ppf stat =
Format.fprintf
ppf
"â %a (%a/s) â %a (%a/s)"
print_size64
stat.total_sent
print_size
stat.current_outflow
print_size64
stat.total_recv
print_size
stat.current_inflow
let encoding =
let open Data_encoding in
def "p2p_stat" ~description:"Statistics about the p2p network."
@@ conv
(fun {total_sent; total_recv; current_inflow; current_outflow} ->
(total_sent, total_recv, current_inflow, current_outflow))
(fun (total_sent, total_recv, current_inflow, current_outflow) ->
{total_sent; total_recv; current_inflow; current_outflow})
(obj4
(req "total_sent" int64)
(req "total_recv" int64)
(req "current_inflow" int31)
(req "current_outflow" int31))
let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_stat.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
total_sent : int64;
total_recv : int64;
current_inflow : Z;
current_outflow : Z }.
Definition empty : t :=
{|
total_sent :=
(* ❌ Constant of type int64 is converted to int *)
0;
total_recv :=
(* ❌ Constant of type int64 is converted to int *)
0; current_inflow := 0; current_outflow := 0 |}.
Definition print_size (ppf : Stdlib.Format.formatter) (sz : Z) : unit :=
let ratio (n : Z) : Z :=
Stdlib.op_divpoint (Stdlib.float_of_int sz)
(Stdlib.float_of_int (Z.shiftl 1 n)) in
if OCaml.Stdlib.lt sz (Z.shiftl 1 10) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " B" % string
CamlinternalFormatBasics.End_of_format)) "%d B" % string) sz
else
if OCaml.Stdlib.lt sz (Z.shiftl 1 20) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " kiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f kiB" % string)
(ratio 10)
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " MiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f MiB" % string)
(ratio 20).
Definition print_size64 (ppf : Stdlib.Format.formatter) (sz : int64) : unit :=
let ratio (n : Z) : Z :=
Stdlib.op_divpoint (to_float sz) (Stdlib.float_of_int (Z.shiftl 1 n)) in
if
OCaml.Stdlib.lt sz
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 10) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " B" % string
CamlinternalFormatBasics.End_of_format)) "%Ld B" % string) sz
else
if
OCaml.Stdlib.lt sz
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 20) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " kiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f kiB" % string)
(ratio 10)
else
if
OCaml.Stdlib.lt sz
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 30) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " MiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f MiB" % string)
(ratio 20)
else
if
OCaml.Stdlib.lt sz
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 40) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " GiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f GiB" % string)
(ratio 30)
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " TiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f TiB" % string)
(ratio 40).
Definition pp (ppf : Stdlib.Format.formatter) (stat : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "↗ " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "/s) ↘ " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "/s)" % string
CamlinternalFormatBasics.End_of_format)))))))))
"↗ %a (%a/s) ↘ %a (%a/s)" % string) print_size64 (total_sent stat)
print_size (current_outflow stat) print_size64 (total_recv stat) print_size
(current_inflow stat).
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_stat" % string
(* ❌ expected an argument *)
expected_argument (Some "Statistics about the p2p network." % string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
total_sent := total_sent;
total_recv := total_recv;
current_inflow := current_inflow;
current_outflow := current_outflow
|} := function_parameter in
(total_sent, total_recv, current_inflow, current_outflow))
(fun function_parameter =>
let '(total_sent, total_recv, current_inflow, current_outflow) :=
function_parameter in
{| total_sent := total_sent; total_recv := total_recv;
current_inflow := current_inflow; current_outflow := current_outflow
|}) None
(obj4 (req None None "total_sent" % string int64)
(req None None "total_recv" % string int64)
(req None None "current_inflow" % string int31)
(req None None "current_outflow" % string int31))).
src/lib_base/p2p_version.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) type t = int let pp = Format.pp_print_int let encoding = let open Data_encoding in def "p2p_version" ~description:"A version number for the p2p layer." uint16 let zero = 0 let supported = [zero] let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Z.
Definition pp : Stdlib.Format.formatter -> Z -> unit := Format.pp_print_int.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
def "p2p_version" % string None
(Some "A version number for the p2p layer." % string) uint16.
Definition zero : Z := 0.
Definition supported : list Z := cons zero [].
src/lib_base/preapply_result.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type 'error t = {
applied : (Operation_hash.t * Operation.t) list;
refused : (Operation.t * 'error list) Operation_hash.Map.t;
branch_refused : (Operation.t * 'error list) Operation_hash.Map.t;
branch_delayed : (Operation.t * 'error list) Operation_hash.Map.t;
}
let empty =
{
applied = [];
refused = Operation_hash.Map.empty;
branch_refused = Operation_hash.Map.empty;
branch_delayed = Operation_hash.Map.empty;
}
let map f r =
{
applied = r.applied;
refused = Operation_hash.Map.map f r.refused;
branch_refused = Operation_hash.Map.map f r.branch_refused;
branch_delayed = Operation_hash.Map.map f r.branch_delayed;
}
let encoding error_encoding =
let open Data_encoding in
let operation_encoding =
merge_objs
(obj1 (req "hash" Operation_hash.encoding))
(dynamic_size Operation.encoding)
in
let refused_encoding =
merge_objs
(obj1 (req "hash" Operation_hash.encoding))
(merge_objs
(dynamic_size Operation.encoding)
(obj1 (req "error" error_encoding)))
in
let build_list map = Operation_hash.Map.bindings map in
let build_map list =
List.fold_right
(fun (k, e) m -> Operation_hash.Map.add k e m)
list
Operation_hash.Map.empty
in
conv
(fun {applied; refused; branch_refused; branch_delayed} ->
( applied,
build_list refused,
build_list branch_refused,
build_list branch_delayed ))
(fun (applied, refused, branch_refused, branch_delayed) ->
let refused = build_map refused in
let branch_refused = build_map branch_refused in
let branch_delayed = build_map branch_delayed in
{applied; refused; branch_refused; branch_delayed})
(obj4
(req "applied" (list operation_encoding))
(req "refused" (list refused_encoding))
(req "branch_refused" (list refused_encoding))
(req "branch_delayed" (list refused_encoding)))
let operations t =
let ops =
List.fold_left
(fun acc (h, op) -> Operation_hash.Map.add h op acc)
Operation_hash.Map.empty
t.applied
in
let ops =
Operation_hash.Map.fold
(fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
t.branch_delayed
ops
in
let ops =
Operation_hash.Map.fold
(fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
t.branch_refused
ops
in
ops
src/lib_base/preapply_result.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t {error : Type} := {
applied : list (Tezos_crypto.Operation_hash.t * Tezos_base.Operation.t);
refused :
Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
branch_refused :
Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
branch_delayed :
Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error)) }.
Arguments t : clear implicits.
Definition empty {A : Type} : t A :=
{| applied := []; refused := Operation_hash.Map.empty;
branch_refused := Operation_hash.Map.empty;
branch_delayed := Operation_hash.Map.empty |}.
Definition map {A B : Type}
(f : (Tezos_base.Operation.t * (list A)) -> Tezos_base.Operation.t * (list B))
(r : t A) : t B :=
{| applied := applied r; refused := Operation_hash.Map.map f (refused r);
branch_refused := Operation_hash.Map.map f (branch_refused r);
branch_delayed := Operation_hash.Map.map f (branch_delayed r) |}.
Definition encoding {A : Type}
(error_encoding : Tezos_data_encoding.Data_encoding.encoding (list A))
: Tezos_data_encoding.Data_encoding.encoding (t A) :=
let operation_encoding :=
merge_objs (obj1 (req None None "hash" % string Operation_hash.encoding))
(dynamic_size None Operation.encoding) in
let refused_encoding :=
merge_objs (obj1 (req None None "hash" % string Operation_hash.encoding))
(merge_objs (dynamic_size None Operation.encoding)
(obj1 (req None None "error" % string error_encoding))) in
let build_list {B : Type} (map : Tezos_crypto.Operation_hash.Map.t B)
: list (Tezos_crypto.Operation_hash.Map.key * B) :=
Operation_hash.Map.bindings map in
let build_map {B : Type}
(list : list (Tezos_crypto.Operation_hash.Map.key * B))
: Tezos_crypto.Operation_hash.Map.t B :=
Stdlib.List.fold_right
(fun function_parameter =>
let '(k, e) := function_parameter in
fun m => Operation_hash.Map.add k e m) list Operation_hash.Map.empty in
conv
(fun function_parameter =>
let '{|
applied := applied;
refused := refused;
branch_refused := branch_refused;
branch_delayed := branch_delayed
|} := function_parameter in
(applied, (build_list refused), (build_list branch_refused),
(build_list branch_delayed)))
(fun function_parameter =>
let '(applied, refused, branch_refused, branch_delayed) :=
function_parameter in
let refused := build_map refused in
let branch_refused := build_map branch_refused in
let branch_delayed := build_map branch_delayed in
{| applied := applied; refused := refused;
branch_refused := branch_refused; branch_delayed := branch_delayed |})
None
(obj4 (req None None "applied" % string (list None operation_encoding))
(req None None "refused" % string (list None refused_encoding))
(req None None "branch_refused" % string (list None refused_encoding))
(req None None "branch_delayed" % string (list None refused_encoding))).
Definition operations {A : Type} (t : t A)
: Tezos_crypto.Operation_hash.Map.t Tezos_base.Operation.t :=
let ops :=
Stdlib.List.fold_left
(fun acc =>
fun function_parameter =>
let '(h, op) := function_parameter in
Operation_hash.Map.add h op acc) Operation_hash.Map.empty (applied t)
in
let ops :=
Operation_hash.Map.fold
(fun h =>
fun function_parameter =>
let '(op, _err) := function_parameter in
fun acc => Operation_hash.Map.add h op acc) (branch_delayed t) ops in
let ops :=
Operation_hash.Map.fold
(fun h =>
fun function_parameter =>
let '(op, _err) := function_parameter in
fun acc => Operation_hash.Map.add h op acc) (branch_refused t) ops in
ops.
src/lib_base/protocol.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {expected_env : env_version; components : component list}
and component = {
name : string;
interface : string option;
implementation : string;
}
and env_version = V1
include Compare.Make (struct
type nonrec t = t
let compare = Pervasives.compare
end)
let component_encoding =
let open Data_encoding in
conv
(fun {name; interface; implementation} ->
(name, interface, implementation))
(fun (name, interface, implementation) ->
{name; interface; implementation})
(obj3
(req "name" string)
(opt "interface" string)
(req "implementation" string))
let env_version_encoding =
let open Data_encoding in
conv
(function V1 -> 0)
(function 0 -> V1 | _ -> failwith "unexpected environment version")
int16
let encoding =
let open Data_encoding in
def
"protocol"
~description:
"The environment a protocol relies on and the components a protocol is \
made of."
@@ conv
(fun {expected_env; components} -> (expected_env, components))
(fun (expected_env, components) -> {expected_env; components})
(obj2
(req "expected_env_version" env_version_encoding)
(req "components" (list component_encoding)))
let bounded_encoding ?max_size () =
match max_size with
| None ->
encoding
| Some max_size ->
Data_encoding.check_size max_size encoding
let pp ppf op =
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op)
let env_version_to_string = function V1 -> "V1"
let pp_ocaml_component ppf {name; interface; implementation} =
Format.fprintf
ppf
"@[{@[<v 1> name = %S ;@ interface = %a ;@ implementation = %S ;@]@ }@]"
name
(fun ppf -> function None -> Format.fprintf ppf "None" | Some s ->
Format.fprintf ppf "Some %S" s)
interface
implementation
let pp_ocaml ppf {expected_env; components} =
Format.fprintf
ppf
"@[{@[<v 1> expected_env = %s ;@ components = [@[<v>%a@]] ;@]@ }@]"
(env_version_to_string expected_env)
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf " ;@ ")
pp_ocaml_component)
components
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b
let hash proto = Protocol_hash.hash_bytes [to_bytes proto]
let hash_raw proto = Protocol_hash.hash_bytes [proto]
module Meta = struct
type t = {
hash : Protocol_hash.t option;
expected_env_version : env_version option;
modules : string list;
}
let encoding =
let open Data_encoding in
def "protocol.meta"
(* FIXME: add ~description argument *)
@@ conv
(fun {hash; expected_env_version; modules} ->
(hash, expected_env_version, modules))
(fun (hash, expected_env_version, modules) ->
{hash; expected_env_version; modules})
@@ obj3
(opt
"hash"
~description:"Used to force the hash of the protocol"
Protocol_hash.encoding)
(opt "expected_env_version" env_version_encoding)
(req
"modules"
~description:"Modules comprising the protocol"
(list string))
end
let () =
Data_encoding.Registration.register ~pp:pp_ocaml encoding ;
Data_encoding.Registration.register Meta.encoding
src/lib_base/protocol.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive env_version : Type :=
| V1 : env_version.
(* ❌ Structure item `include` not handled. *)
include
Definition component_encoding
: Tezos_data_encoding.Data_encoding.encoding component :=
conv
(fun function_parameter =>
let '{|
name := name;
interface := interface;
implementation := implementation
|} := function_parameter in
(name, interface, implementation))
(fun function_parameter =>
let '(name, interface, implementation) := function_parameter in
{| name := name; interface := interface; implementation := implementation
|}) None
(obj3 (req None None "name" % string string)
(opt None None "interface" % string string)
(req None None "implementation" % string string)).
Definition env_version_encoding
: Tezos_data_encoding.Data_encoding.encoding env_version :=
conv
(fun function_parameter =>
let 'V1 := function_parameter in
0)
(fun function_parameter =>
match function_parameter with
| 0 => V1
| _ => OCaml.Stdlib.failwith "unexpected environment version" % string
end) None int16.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "protocol" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The environment a protocol relies on and the components a protocol is made of."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{| expected_env := expected_env; components := components |} :=
function_parameter in
(expected_env, components))
(fun function_parameter =>
let '(expected_env, components) := function_parameter in
{| expected_env := expected_env; components := components |}) None
(obj2 (req None None "expected_env_version" % string env_version_encoding)
(req None None "components" % string (list None component_encoding)))).
Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding t :=
let 'tt := function_parameter in
match max_size with
| None => encoding
| Some max_size => Data_encoding.check_size max_size encoding
end.
Definition pp (ppf : Stdlib.Format.formatter) (op : t) : unit :=
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op).
Definition env_version_to_string (function_parameter : env_version) : string :=
let 'V1 := function_parameter in
"V1" % string.
Definition pp_ocaml_component
(ppf : Stdlib.Format.formatter) (function_parameter : component) : unit :=
let '{|
name := name;
interface := interface;
implementation := implementation
|} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Char_literal "{" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 1>" % string
CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
(CamlinternalFormatBasics.String_literal " name = " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"interface = " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"implementation = " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" ;" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Char_literal
"}" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))))
"@[{@[<v 1> name = %S ;@ interface = %a ;@ implementation = %S ;@]@ }@]" %
string) name
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "None" % string
CamlinternalFormatBasics.End_of_format) "None" % string)
| Some s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Some " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "Some %S" % string) s
end) interface implementation.
Definition pp_ocaml (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
let '{| expected_env := expected_env; components := components |} :=
function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Char_literal "{" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 1>" % string
CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
(CamlinternalFormatBasics.String_literal " expected_env = " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"components = [" % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal
"] ;" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Char_literal
"}" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[{@[<v 1> expected_env = %s ;@ components = [@[<v>%a@]] ;@]@ }@]" %
string) (env_version_to_string expected_env)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)) " ;@ " % string)))
pp_ocaml_component) components.
Definition to_bytes (v : t) : Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding v.
Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
Data_encoding.Binary.of_bytes encoding b.
Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
Data_encoding.Binary.of_bytes_exn encoding b.
Definition hash (proto : t) : Tezos_crypto.Protocol_hash.t :=
Protocol_hash.hash_bytes None (cons (to_bytes proto) []).
Definition hash_raw (proto : Stdlib.Bytes.t) : Tezos_crypto.Protocol_hash.t :=
Protocol_hash.hash_bytes None (cons proto []).
Module Meta.
Record t := {
hash : option Tezos_crypto.Protocol_hash.t;
expected_env_version : option env_version;
modules : list string }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg := def "protocol.meta" % string in
fun eta => arg None None eta)
(apply
(let arg :=
conv
(fun function_parameter =>
let '{|
hash := hash;
expected_env_version := expected_env_version;
modules := modules
|} := function_parameter in
(hash, expected_env_version, modules))
(fun function_parameter =>
let '(hash, expected_env_version, modules) := function_parameter
in
{| hash := hash; expected_env_version := expected_env_version;
modules := modules |}) in
fun eta => arg None eta)
(obj3
(opt None (Some "Used to force the hash of the protocol" % string)
"hash" % string Protocol_hash.encoding)
(opt None None "expected_env_version" % string env_version_encoding)
(req None (Some "Modules comprising the protocol" % string)
"modules" % string (list None string)))).
End Meta.
src/lib_base/s.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type T = sig
type t
include Compare.S with type t := t
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t option
end
module type HASHABLE = sig
include T
type hash
val hash : t -> hash
val hash_raw : Bytes.t -> hash
end
module type SET = sig
type elt
type t
val empty : t
val is_empty : t -> bool
val mem : elt -> t -> bool
val add : elt -> t -> t
val singleton : elt -> t
val remove : elt -> t -> t
val union : t -> t -> t
val inter : t -> t -> t
val diff : t -> t -> t
val compare : t -> t -> int
val equal : t -> t -> bool
val subset : t -> t -> bool
val iter : (elt -> unit) -> t -> unit
val map : (elt -> elt) -> t -> t
val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
val for_all : (elt -> bool) -> t -> bool
val exists : (elt -> bool) -> t -> bool
val filter : (elt -> bool) -> t -> t
val partition : (elt -> bool) -> t -> t * t
val cardinal : t -> int
val elements : t -> elt list
val min_elt_opt : t -> elt option
val max_elt_opt : t -> elt option
val choose_opt : t -> elt option
val split : elt -> t -> t * bool * t
val find_opt : elt -> t -> elt option
val find_first_opt : (elt -> bool) -> t -> elt option
val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
end
module type MAP = sig
type key
type +'a t
val empty : 'a t
val is_empty : 'a t -> bool
val mem : key -> 'a t -> bool
val add : key -> 'a -> 'a t -> 'a t
val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
val singleton : key -> 'a -> 'a t
val remove : key -> 'a t -> 'a t
val merge :
(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val for_all : (key -> 'a -> bool) -> 'a t -> bool
val exists : (key -> 'a -> bool) -> 'a t -> bool
val filter : (key -> 'a -> bool) -> 'a t -> 'a t
val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
val cardinal : 'a t -> int
val bindings : 'a t -> (key * 'a) list
val min_binding_opt : 'a t -> (key * 'a) option
val max_binding_opt : 'a t -> (key * 'a) option
val choose_opt : 'a t -> (key * 'a) option
val split : key -> 'a t -> 'a t * 'a option * 'a t
val find_opt : key -> 'a t -> 'a option
val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
val map : ('a -> 'b) -> 'a t -> 'b t
val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
end
src/lib_base/s.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module T.
Record signature {t : Type} := {
t := t;
include;
pp : Stdlib.Format.formatter -> t -> unit;
encoding : Tezos_data_encoding.Data_encoding.t t;
to_bytes : t -> Stdlib.Bytes.t;
of_bytes : Stdlib.Bytes.t -> option t;
}.
Arguments signature : clear implicits.
End T.
Module HASHABLE.
Record signature {t hash : Type} := {
include;
hash := hash;
hash : t -> hash;
hash_raw : Stdlib.Bytes.t -> hash;
}.
Arguments signature : clear implicits.
End HASHABLE.
Module SET.
Record signature {elt t : Type} := {
elt := elt;
t := t;
empty : t;
is_empty : t -> bool;
mem : elt -> t -> bool;
add : elt -> t -> t;
singleton : elt -> t;
remove : elt -> t -> t;
union : t -> t -> t;
inter : t -> t -> t;
diff : t -> t -> t;
compare : t -> t -> Z;
equal : t -> t -> bool;
subset : t -> t -> bool;
iter : (elt -> unit) -> t -> unit;
map : (elt -> elt) -> t -> t;
fold : forall {a : Type}, (elt -> a -> a) -> t -> a -> a;
for_all : (elt -> bool) -> t -> bool;
_exists : (elt -> bool) -> t -> bool;
filter : (elt -> bool) -> t -> t;
partition : (elt -> bool) -> t -> t * t;
cardinal : t -> Z;
elements : t -> list elt;
min_elt_opt : t -> option elt;
max_elt_opt : t -> option elt;
choose_opt : t -> option elt;
split : elt -> t -> t * bool * t;
find_opt : elt -> t -> option elt;
find_first_opt : (elt -> bool) -> t -> option elt;
find_last_opt : (elt -> bool) -> t -> option elt;
of_list : (list elt) -> t;
}.
Arguments signature : clear implicits.
End SET.
Module MAP.
Record signature {key t : Type} := {
key := key;
polymorphic_abstract_type;
empty : forall {a : Type}, t a;
is_empty : forall {a : Type}, (t a) -> bool;
mem : forall {a : Type}, key -> (t a) -> bool;
add : forall {a : Type}, key -> a -> (t a) -> t a;
update : forall {a : Type}, key -> ((option a) -> option a) -> (t a) -> t a;
singleton : forall {a : Type}, key -> a -> t a;
remove : forall {a : Type}, key -> (t a) -> t a;
merge : forall {a b c : Type}, (key -> (option a) -> (option b) -> option c)
-> (t a) -> (t b) -> t c;
union : forall {a : Type}, (key -> a -> a -> option a) ->
(t a) -> (t a) -> t a;
compare : forall {a : Type}, (a -> a -> Z) -> (t a) -> (t a) -> Z;
equal : forall {a : Type}, (a -> a -> bool) -> (t a) -> (t a) -> bool;
iter : forall {a : Type}, (key -> a -> unit) -> (t a) -> unit;
fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
for_all : forall {a : Type}, (key -> a -> bool) -> (t a) -> bool;
_exists : forall {a : Type}, (key -> a -> bool) -> (t a) -> bool;
filter : forall {a : Type}, (key -> a -> bool) -> (t a) -> t a;
partition : forall {a : Type}, (key -> a -> bool) -> (t a) -> (t a) * (t a);
cardinal : forall {a : Type}, (t a) -> Z;
bindings : forall {a : Type}, (t a) -> list (key * a);
min_binding_opt : forall {a : Type}, (t a) -> option (key * a);
max_binding_opt : forall {a : Type}, (t a) -> option (key * a);
choose_opt : forall {a : Type}, (t a) -> option (key * a);
split : forall {a : Type}, key -> (t a) -> (t a) * (option a) * (t a);
find_opt : forall {a : Type}, key -> (t a) -> option a;
find_first_opt : forall {a : Type}, (key -> bool) ->
(t a) -> option (key * a);
find_last_opt : forall {a : Type}, (key -> bool) ->
(t a) -> option (key * a);
map : forall {a b : Type}, (a -> b) -> (t a) -> t b;
mapi : forall {a b : Type}, (key -> a -> b) -> (t a) -> t b;
}.
Arguments signature : clear implicits.
End MAP.
src/lib_base/test_chain_status.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t =
| Not_running
| Forking of {protocol : Protocol_hash.t; expiration : Time.Protocol.t}
| Running of {
chain_id : Chain_id.t;
genesis : Block_hash.t;
protocol : Protocol_hash.t;
expiration : Time.Protocol.t;
}
let encoding =
let open Data_encoding in
def
"test_chain_status"
~description:
"The status of the test chain: not_running (there is no test chain at \
the moment), forking (the test chain is being setup), running (the \
test chain is running)."
@@ union
[ case
(Tag 0)
~title:"Not_running"
(obj1 (req "status" (constant "not_running")))
(function Not_running -> Some () | _ -> None)
(fun () -> Not_running);
case
(Tag 1)
~title:"Forking"
(obj3
(req "status" (constant "forking"))
(req "protocol" Protocol_hash.encoding)
(req "expiration" Time.Protocol.encoding))
(function
| Forking {protocol; expiration} ->
Some ((), protocol, expiration)
| _ ->
None)
(fun ((), protocol, expiration) -> Forking {protocol; expiration});
case
(Tag 2)
~title:"Running"
(obj5
(req "status" (constant "running"))
(req "chain_id" Chain_id.encoding)
(req "genesis" Block_hash.encoding)
(req "protocol" Protocol_hash.encoding)
(req "expiration" Time.Protocol.encoding))
(function
| Running {chain_id; genesis; protocol; expiration} ->
Some ((), chain_id, genesis, protocol, expiration)
| _ ->
None)
(fun ((), chain_id, genesis, protocol, expiration) ->
Running {chain_id; genesis; protocol; expiration}) ]
let pp ppf = function
| Not_running ->
Format.fprintf ppf "@[<v 2>Not running@]"
| Forking {protocol; expiration} ->
Format.fprintf
ppf
"@[<v 2>Forking %a (expires %a)@]"
Protocol_hash.pp
protocol
Time.System.pp_hum
(Time.System.of_protocol_exn expiration)
| Running {chain_id; genesis; protocol; expiration} ->
Format.fprintf
ppf
"@[<v 2>Running %a@ Genesis: %a@ Net id: %a@ Expiration: %a@]"
Protocol_hash.pp
protocol
Block_hash.pp
genesis
Chain_id.pp
chain_id
Time.System.pp_hum
(Time.System.of_protocol_exn expiration)
let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/test_chain_status.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive t : Type :=
| Not_running : t
| Forking : Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t
| Running : Tezos_crypto.Chain_id.t -> Tezos_crypto.Block_hash.t ->
Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "test_chain_status" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The status of the test chain: not_running (there is no test chain at the moment), forking (the test chain is being setup), running (the test chain is running)."
% string) in
fun eta => arg None eta)
(union None
(cons
(case "Not_running" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(obj1
(req None None "status" % string (constant "not_running" % string)))
(fun function_parameter =>
match function_parameter with
| Not_running => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Not_running))
(cons
(case "Forking" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(obj3
(req None None "status" % string (constant "forking" % string))
(req None None "protocol" % string Protocol_hash.encoding)
(req None None "expiration" % string Time.Protocol.encoding))
(fun function_parameter =>
match function_parameter with
| Forking {| protocol := protocol; expiration := expiration |} =>
Some (tt, protocol, expiration)
| _ => None
end)
(fun function_parameter =>
let '(tt, protocol, expiration) := function_parameter in
Forking {| protocol := protocol; expiration := expiration |}))
(cons
(case "Running" % string None
(Tezos_data_encoding.Data_encoding.Tag 2)
(obj5
(req None None "status" % string (constant "running" % string))
(req None None "chain_id" % string Chain_id.encoding)
(req None None "genesis" % string Block_hash.encoding)
(req None None "protocol" % string Protocol_hash.encoding)
(req None None "expiration" % string Time.Protocol.encoding))
(fun function_parameter =>
match function_parameter with
|
Running {|
chain_id := chain_id;
genesis := genesis;
protocol := protocol;
expiration := expiration
|} => Some (tt, chain_id, genesis, protocol, expiration)
| _ => None
end)
(fun function_parameter =>
let '(tt, chain_id, genesis, protocol, expiration) :=
function_parameter in
Running
{| chain_id := chain_id; genesis := genesis;
protocol := protocol; expiration := expiration |})) [])))).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
match function_parameter with
| Not_running =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Not running" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))
"@[<v 2>Not running@]" % string)
| Forking {| protocol := protocol; expiration := expiration |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Forking " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (expires " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>Forking %a (expires %a)@]" % string) Protocol_hash.pp protocol
Time.System.pp_hum (Time.System.of_protocol_exn expiration)
|
Running {|
chain_id := chain_id;
genesis := genesis;
protocol := protocol;
expiration := expiration
|} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Running " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "Genesis: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"Net id: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"Expiration: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[<v 2>Running %a@ Genesis: %a@ Net id: %a@ Expiration: %a@]" % string)
Protocol_hash.pp protocol Block_hash.pp genesis Chain_id.pp chain_id
Time.System.pp_hum (Time.System.of_protocol_exn expiration)
end.
src/lib_base/time.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Protocol = struct
type t = int64
let epoch = 0L
let diff = Int64.sub
let add = Int64.add
let of_ptime t =
let (days, ps) = Ptime.Span.to_d_ps (Ptime.to_span t) in
let s_days = Int64.mul (Int64.of_int days) 86_400L in
Int64.add s_days (Int64.div ps 1_000_000_000_000L)
let to_ptime t =
let days = Int64.to_int (Int64.div t 86_400L) in
let ps = Int64.mul (Int64.rem t 86_400L) 1_000_000_000_000L in
match Option.apply ~f:Ptime.of_span (Ptime.Span.of_d_ps (days, ps)) with
| None ->
invalid_arg "Time.Protocol.to_ptime"
| Some ptime ->
ptime
let of_notation s =
match Ptime.of_rfc3339 s with
| Ok (t, _, _) ->
Some (of_ptime t)
| Error _ ->
None
let of_notation_exn s =
match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
| Error (`Msg msg) ->
invalid_arg ("Time.Protocol.of_notation: " ^ msg)
| Ok (t, _, _) ->
of_ptime t
let to_notation t = Ptime.to_rfc3339 ~frac_s:0 ~tz_offset_s:0 (to_ptime t)
let of_seconds x = x
let to_seconds x = x
let rfc_encoding =
let open Data_encoding in
def
"timestamp.rfc"
~title:"RFC 3339 formatted timestamp"
~description:"A date in RFC 3339 notation."
@@ conv
to_notation
(fun s ->
match of_notation s with
| Some s ->
s
| None ->
Data_encoding.Json.cannot_destruct "Time.Protocol.of_notation")
string
let encoding =
let open Data_encoding in
def
"timestamp.protocol"
~description:
"A timestamp as seen by the protocol: second-level precision, epoch \
based."
@@ splitted
~binary:int64
~json:
(union
[ case
Json_only
~title:"RFC encoding"
rfc_encoding
(fun i -> Some i)
(fun i -> i);
case
Json_only
~title:"Second since epoch"
int64
(fun _ -> None)
(fun i -> i) ])
let rpc_arg =
RPC_arg.make
~name:(Format.asprintf "date")
~descr:(Format.asprintf "A date in seconds from epoch")
~destruct:(fun s ->
if s = "none" || s = "epoch" then Ok epoch
else
match Int64.of_string s with
| t ->
Ok t
| exception _ ->
Error (Format.asprintf "failed to parse time (epoch): %S" s))
~construct:Int64.to_string
()
let pp_hum ppf t = Ptime.pp_rfc3339 () ppf (to_ptime t)
include Compare.Make (Int64)
end
module System = struct
type t = Ptime.t
let epoch = Ptime.epoch
module Span = struct
type t = Ptime.Span.t
let multiply_exn f s =
let open Ptime.Span in
Option.unopt_exn
(Failure "Time.System.Span.multiply_exn")
(of_float_s (f *. Ptime.Span.to_float_s s))
let of_seconds_exn f =
match Ptime.Span.of_float_s f with
| None ->
invalid_arg "Time.System.Span.of_seconds_exn"
| Some s ->
s
let encoding =
let open Data_encoding in
def
"timespan.system"
~description:"A span of time, as seen by the local computer."
@@ conv
Ptime.Span.to_float_s
(fun f ->
match Ptime.Span.of_float_s f with
| None ->
invalid_arg "Time.System.Span.encoding"
| Some s ->
s)
float
let rpc_arg =
RPC_arg.make
~name:(Format.asprintf "timespan")
~descr:(Format.asprintf "A span of time in seconds")
~destruct:(fun s ->
match Ptime.Span.of_float_s (float_of_string s) with
| Some t ->
Ok t
| None ->
Error (Format.asprintf "failed to parse timespan: %S" s)
| exception _ ->
Error (Format.asprintf "failed to parse timespan: %S" s))
~construct:(fun s -> string_of_float (Ptime.Span.to_float_s s))
()
end
let of_seconds_opt x =
let days = Int64.to_int (Int64.div x 86_400L) in
let ps = Int64.mul (Int64.rem x 86_400L) 1_000_000_000_000L in
Option.apply ~f:Ptime.of_span (Ptime.Span.of_d_ps (days, ps))
let of_seconds_exn x =
match of_seconds_opt x with
| Some t ->
t
| None ->
invalid_arg "Time.of_seconds"
let to_seconds x =
let (days, ps) = Ptime.(Span.to_d_ps (to_span x)) in
let s_days = Int64.mul (Int64.of_int days) 86_400L in
Int64.add s_days (Int64.div ps 1_000_000_000_000L)
let of_protocol_exn = of_seconds_exn
let of_protocol_opt = of_seconds_opt
let to_protocol = to_seconds
let of_notation_opt s =
match Ptime.of_rfc3339 s with Ok (t, _, _) -> Some t | Error _ -> None
let of_notation_exn s =
match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
| Ok (t, _, _) ->
t
| Error (`Msg msg) ->
invalid_arg ("Time.of_notation: " ^ msg)
let to_notation t = Ptime.to_rfc3339 t
let rfc_encoding =
let open Data_encoding in
def
"timestamp.rfc"
~title:"RFC 3339 formatted timestamp"
~description:"A date in RFC 3339 notation."
@@ conv
to_notation
(fun s ->
match of_notation_opt s with
| Some s ->
s
| None ->
Data_encoding.Json.cannot_destruct "Time.of_notation")
string
let encoding =
let open Data_encoding in
let binary = conv to_seconds of_seconds_exn int64 in
let json =
union
[ case
Json_only
~title:"RFC encoding"
rfc_encoding
(fun i -> Some i)
(fun i -> i);
case
Json_only
~title:"Second since epoch"
int64
(fun _ -> None)
(fun i -> of_seconds_exn i) ]
in
def
"timestamp.system"
~description:
"A timestamp as seen by the underlying, local computer: \
subsecond-level precision, epoch or rfc3339 based."
@@ splitted ~binary ~json
let rpc_arg =
RPC_arg.make
~name:(Format.asprintf "date")
~descr:(Format.asprintf "A date in seconds from epoch")
~destruct:(fun s ->
if s = "none" || s = "epoch" then Ok Ptime.epoch
else
match of_notation_opt s with
| Some t ->
Ok t
| None -> (
match of_seconds_exn (Int64.of_string s) with
| t ->
Ok t
| exception _ ->
Error (Format.asprintf "failed to parse time (epoch): %S" s) ))
~construct:to_notation
()
let pp_hum ppf t = Ptime.pp_rfc3339 () ppf t
type 'a stamped = {data : 'a; stamp : Ptime.t}
let stamped_encoding arg_encoding =
let open Data_encoding in
conv
(fun {stamp; data} -> (stamp, data))
(fun (stamp, data) -> {stamp; data})
(tup2 encoding arg_encoding)
let pp_stamped pp fmt {data; stamp} =
Format.fprintf fmt "%a(%a)" pp data pp_hum stamp
let stamp ~time data = {data; stamp = time}
let recent a1 a2 =
match (a1, a2) with
| (None, None) ->
None
| (None, (Some _ as a)) | ((Some _ as a), None) ->
a
| (Some (_, t1), Some (_, t2)) ->
if Ptime.compare t1 t2 < 0 then a2 else a1
let hash t = Int64.to_int (to_seconds t)
include Compare.Make (Ptime)
module Set = Set.Make (Ptime)
module Map = Map.Make (Ptime)
module Table = Hashtbl.Make (struct
include Ptime
let hash = hash
end)
end
let () =
Data_encoding.Registration.register ~pp:Protocol.pp_hum Protocol.encoding ;
Data_encoding.Registration.register ~pp:System.pp_hum System.encoding ;
Data_encoding.Registration.register System.Span.encoding
src/lib_base/time.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Protocol.
Definition t := int64.
Definition epoch : int64 :=
(* ❌ Constant of type int64 is converted to int *)
0.
Definition diff : int64 -> int64 -> int64 := Int64.sub.
Definition add : int64 -> int64 -> int64 := Int64.add.
Definition of_ptime (t : Ptime.t) : int64 :=
let '(days, ps) := Ptime.Span.to_d_ps (Ptime.to_span t) in
let s_days :=
Int64.mul (Int64.of_int days)
(* ❌ Constant of type int64 is converted to int *)
86400 in
Int64.add s_days
(Int64.div ps
(* ❌ Constant of type int64 is converted to int *)
1000000000000).
Definition to_ptime (t : int64) : Ptime.t :=
let days :=
Int64.to_int
(Int64.div t
(* ❌ Constant of type int64 is converted to int *)
86400) in
let ps :=
Int64.mul
(Int64.rem t
(* ❌ Constant of type int64 is converted to int *)
86400)
(* ❌ Constant of type int64 is converted to int *)
1000000000000 in
match Option.apply Ptime.of_span (Ptime.Span.of_d_ps (days, ps)) with
| None => OCaml.Stdlib.invalid_arg "Time.Protocol.to_ptime" % string
| Some ptime => ptime
end.
Definition of_notation (s : string) : option int64 :=
match Ptime.of_rfc3339 None None None s with
| Stdlib.Ok (t, _, _) => Some (of_ptime t)
| Stdlib.Error _ => None
end.
Definition of_notation_exn (s : string) : int64 :=
match rfc3339_error_to_msg (of_rfc3339 None None None s) with
| Stdlib.Error (Msg msg) =>
OCaml.Stdlib.invalid_arg
(String.append "Time.Protocol.of_notation: " % string msg)
| Stdlib.Ok (t, _, _) => of_ptime t
end.
Definition to_notation (t : int64) : string :=
Ptime.to_rfc3339 None (Some 0) (Some 0) (to_ptime t).
Definition of_seconds {A : Type} (x : A) : A := x.
Definition to_seconds {A : Type} (x : A) : A := x.
Definition rfc_encoding : Tezos_data_encoding.Data_encoding.encoding int64 :=
apply
(def "timestamp.rfc" % string
(Some "RFC 3339 formatted timestamp" % string)
(Some "A date in RFC 3339 notation." % string))
(conv to_notation
(fun s =>
match of_notation s with
| Some s => s
| None =>
Data_encoding.Json.cannot_destruct
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Time.Protocol.of_notation" % string
CamlinternalFormatBasics.End_of_format)
"Time.Protocol.of_notation" % string)
end) None string).
Definition encoding : Tezos_data_encoding.Data_encoding.encoding int64 :=
apply
(let arg :=
def "timestamp.protocol" % string
(* ❌ expected an argument *)
expected_argument
(Some
"A timestamp as seen by the protocol: second-level precision, epoch based."
% string) in
fun eta => arg None eta)
(splitted
(union None
(cons
(case "RFC encoding" % string None
Tezos_data_encoding.Data_encoding.Json_only rfc_encoding
(fun i => Some i) (fun i => i))
(cons
(case "Second since epoch" % string None
Tezos_data_encoding.Data_encoding.Json_only int64
(fun function_parameter =>
let '_ := function_parameter in
None) (fun i => i)) []))) int64).
Definition rpc_arg : Tezos_rpc.RPC_arg.arg int64 :=
RPC_arg.make
(Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A date in seconds from epoch" % string
CamlinternalFormatBasics.End_of_format)
"A date in seconds from epoch" % string)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "date" % string
CamlinternalFormatBasics.End_of_format) "date" % string))
(fun s =>
if orb (equiv_decb s "none" % string) (equiv_decb s "epoch" % string)
then
Stdlib.Ok epoch
else
let 't := Int64.of_string s in
Stdlib.Ok t) Int64.to_string tt.
Definition pp_hum (ppf : Stdlib.Format.formatter) (t : int64) : unit :=
Ptime.pp_rfc3339 None None None tt ppf (to_ptime t).
(* ❌ Structure item `include` not handled. *)
include
End Protocol.
Module System.
Definition t := Ptime.t.
Definition epoch : Ptime.t := Ptime.epoch.
Module Span.
Definition t := Ptime.Span.t.
Definition multiply_exn (f : Z) (s : Ptime.span) : Ptime.span :=
Option.unopt_exn (OCaml.Failure "Time.System.Span.multiply_exn" % string)
(of_float_s (Stdlib.op_starpoint f (Ptime.Span.to_float_s s))).
Definition of_seconds_exn (f : Z) : Ptime.span :=
match Ptime.Span.of_float_s f with
| None =>
OCaml.Stdlib.invalid_arg "Time.System.Span.of_seconds_exn" % string
| Some s => s
end.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding Ptime.span :=
apply
(let arg :=
def "timespan.system" % string
(* ❌ expected an argument *)
expected_argument
(Some "A span of time, as seen by the local computer." % string) in
fun eta => arg None eta)
(conv Ptime.Span.to_float_s
(fun f =>
match Ptime.Span.of_float_s f with
| None =>
OCaml.Stdlib.invalid_arg "Time.System.Span.encoding" % string
| Some s => s
end) None float).
Definition rpc_arg : Tezos_rpc.RPC_arg.arg Ptime.span :=
RPC_arg.make
(Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A span of time in seconds" % string
CamlinternalFormatBasics.End_of_format)
"A span of time in seconds" % string)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "timespan" % string
CamlinternalFormatBasics.End_of_format) "timespan" % string))
(fun s =>
match Ptime.Span.of_float_s (Stdlib.float_of_string s) with
| Some t => Stdlib.Ok t
| None =>
Stdlib.Error
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"failed to parse timespan: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"failed to parse timespan: %S" % string) s)
end) (fun s => Stdlib.string_of_float (Ptime.Span.to_float_s s)) tt.
End Span.
Definition of_seconds_opt (x : int64) : option Ptime.t :=
let days :=
Int64.to_int
(Int64.div x
(* ❌ Constant of type int64 is converted to int *)
86400) in
let ps :=
Int64.mul
(Int64.rem x
(* ❌ Constant of type int64 is converted to int *)
86400)
(* ❌ Constant of type int64 is converted to int *)
1000000000000 in
Option.apply Ptime.of_span (Ptime.Span.of_d_ps (days, ps)).
Definition of_seconds_exn (x : int64) : Ptime.t :=
match of_seconds_opt x with
| Some t => t
| None => OCaml.Stdlib.invalid_arg "Time.of_seconds" % string
end.
Definition to_seconds (x : Ptime.t) : int64 :=
let '(days, ps) := Span.to_d_ps (to_span x) in
let s_days :=
Int64.mul (Int64.of_int days)
(* ❌ Constant of type int64 is converted to int *)
86400 in
Int64.add s_days
(Int64.div ps
(* ❌ Constant of type int64 is converted to int *)
1000000000000).
Definition of_protocol_exn : int64 -> Ptime.t := of_seconds_exn.
Definition of_protocol_opt : int64 -> option Ptime.t := of_seconds_opt.
Definition to_protocol : Ptime.t -> int64 := to_seconds.
Definition of_notation_opt (s : string) : option Ptime.t :=
match Ptime.of_rfc3339 None None None s with
| Stdlib.Ok (t, _, _) => Some t
| Stdlib.Error _ => None
end.
Definition of_notation_exn (s : string) : Ptime.t :=
match rfc3339_error_to_msg (of_rfc3339 None None None s) with
| Stdlib.Ok (t, _, _) => t
| Stdlib.Error (Msg msg) =>
OCaml.Stdlib.invalid_arg (String.append "Time.of_notation: " % string msg)
end.
Definition to_notation (t : Ptime.t) : string :=
Ptime.to_rfc3339 None None None t.
Definition rfc_encoding
: Tezos_data_encoding.Data_encoding.encoding Ptime.t :=
apply
(def "timestamp.rfc" % string
(Some "RFC 3339 formatted timestamp" % string)
(Some "A date in RFC 3339 notation." % string))
(conv to_notation
(fun s =>
match of_notation_opt s with
| Some s => s
| None =>
Data_encoding.Json.cannot_destruct
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Time.of_notation" % string
CamlinternalFormatBasics.End_of_format)
"Time.of_notation" % string)
end) None string).
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Ptime.t :=
let binary := conv to_seconds of_seconds_exn None int64 in
let json :=
union None
(cons
(case "RFC encoding" % string None
Tezos_data_encoding.Data_encoding.Json_only rfc_encoding
(fun i => Some i) (fun i => i))
(cons
(case "Second since epoch" % string None
Tezos_data_encoding.Data_encoding.Json_only int64
(fun function_parameter =>
let '_ := function_parameter in
None) (fun i => of_seconds_exn i)) [])) in
apply
(let arg :=
def "timestamp.system" % string
(* ❌ expected an argument *)
expected_argument
(Some
"A timestamp as seen by the underlying, local computer: subsecond-level precision, epoch or rfc3339 based."
% string) in
fun eta => arg None eta) (splitted json binary).
Definition rpc_arg : Tezos_rpc.RPC_arg.arg Ptime.t :=
RPC_arg.make
(Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A date in seconds from epoch" % string
CamlinternalFormatBasics.End_of_format)
"A date in seconds from epoch" % string)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "date" % string
CamlinternalFormatBasics.End_of_format) "date" % string))
(fun s =>
if orb (equiv_decb s "none" % string) (equiv_decb s "epoch" % string)
then
Stdlib.Ok Ptime.epoch
else
match of_notation_opt s with
| Some t => Stdlib.Ok t
| None =>
let 't := of_seconds_exn (Int64.of_string s) in
Stdlib.Ok t
end) to_notation tt.
Definition pp_hum (ppf : Stdlib.Format.formatter) (t : Ptime.t) : unit :=
Ptime.pp_rfc3339 None None None tt ppf t.
Record stamped {a : Type} := {
data : a;
stamp : Ptime.t }.
Arguments stamped : clear implicits.
Definition stamped_encoding {A : Type}
(arg_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (stamped A) :=
conv
(fun function_parameter =>
let '{| data := data; stamp := stamp |} := function_parameter in
(stamp, data))
(fun function_parameter =>
let '(stamp, data) := function_parameter in
{| data := data; stamp := stamp |}) None (tup2 encoding arg_encoding).
Definition pp_stamped {A : Type}
(pp : Stdlib.Format.formatter -> A -> unit) (fmt : Stdlib.Format.formatter)
(function_parameter : stamped A) : unit :=
let '{| data := data; stamp := stamp |} := function_parameter in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))) "%a(%a)" % string) pp
data pp_hum stamp.
Definition stamp {A : Type} (time : Ptime.t) (data : A) : stamped A :=
{| data := data; stamp := time |}.
Definition recent {A : Type}
(a1 : option (A * Ptime.t)) (a2 : option (A * Ptime.t))
: option (A * Ptime.t) :=
match (a1, a2) with
| (None, None) => None
| (None, (Some _) as a) | ((Some _) as a, None) => a
| (Some (_, t1), Some (_, t2)) =>
if OCaml.Stdlib.lt (Ptime.compare t1 t2) 0 then
a2
else
a1
end.
Definition hash (t : Ptime.t) : Z := Int64.to_int (to_seconds t).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
End System.
src/lib_base/tzPervasives.ml 32 errors
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Tezos_stdlib module Error_monad = Tezos_error_monad.Error_monad include Tezos_rpc include Tezos_clic include Tezos_crypto include Tezos_micheline module Data_encoding = Tezos_data_encoding.Data_encoding module List = struct include List include Tezos_stdlib.TzList end module String = struct include String include Tezos_stdlib.TzString end module Time = Time module Fitness = Fitness module Block_header = Block_header module Operation = Operation module Protocol = Protocol module Test_chain_status = Test_chain_status module Preapply_result = Preapply_result module Block_locator = Block_locator module Mempool = Mempool module P2p_addr = P2p_addr module P2p_identity = P2p_identity module P2p_peer = P2p_peer module P2p_point = P2p_point module P2p_connection = P2p_connection module P2p_stat = P2p_stat module P2p_version = P2p_version module Distributed_db_version = Distributed_db_version module Network_version = Network_version include Utils.Infix include Error_monad module Internal_event = Internal_event
src/lib_base/tzPervasives.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include (* ❌ This kind of module is not handled. *) unhandled_module Module List. (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include End List. Module String. (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include End String. (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include (* ❌ This kind of module is not handled. *) unhandled_module
src/lib_base/unix/protocol_files.ml 7 errors
open Error_monad
let name = "TEZOS_PROTOCOL"
open Protocol
let ( // ) = Filename.concat
let to_file ~dir:dirname ?hash ?env_version modules =
let config_file =
Data_encoding.Json.construct
Meta.encoding
{hash; expected_env_version = env_version; modules}
in
Lwt_utils_unix.Json.write_file (dirname // name) config_file
let of_file ~dir:dirname =
Lwt_utils_unix.Json.read_file (dirname // name)
>>=? fun json -> return (Data_encoding.Json.destruct Meta.encoding json)
let find_component dirname module_name =
let name_lowercase = String.uncapitalize_ascii module_name in
let implementation = (dirname // name_lowercase) ^ ".ml" in
let interface = implementation ^ "i" in
match (Sys.file_exists implementation, Sys.file_exists interface) with
| (false, _) ->
Pervasives.failwith @@ "Not such file: " ^ implementation
| (true, false) ->
Lwt_utils_unix.read_file implementation
>|= fun implementation ->
{name = module_name; interface = None; implementation}
| _ ->
Lwt_utils_unix.read_file interface
>>= fun interface ->
Lwt_utils_unix.read_file implementation
>|= fun implementation ->
{name = module_name; interface = Some interface; implementation}
let read_dir dir =
of_file ~dir
>>=? fun meta ->
Lwt_list.map_p (find_component dir) meta.modules
>>= fun components ->
let expected_env =
match meta.expected_env_version with None -> V1 | Some v -> v
in
return (meta.hash, {expected_env; components})
open Lwt.Infix
let create_files dir units =
Lwt_utils_unix.remove_dir dir
>>= fun () ->
Lwt_utils_unix.create_dir dir
>>= fun () ->
Lwt_list.map_s
(fun {name; interface; implementation} ->
let name = String.lowercase_ascii name in
let ml = dir // (name ^ ".ml") in
let mli = dir // (name ^ ".mli") in
Lwt_utils_unix.create_file ml implementation
>>= fun () ->
match interface with
| None ->
Lwt.return [ml]
| Some content ->
Lwt_utils_unix.create_file mli content
>>= fun () -> Lwt.return [mli; ml])
units
>>= fun files ->
let files = List.concat files in
Lwt.return files
let write_dir dir ?hash (p : t) =
create_files dir p.components
>>= fun _files ->
to_file
~dir
?hash
~env_version:p.expected_env
(List.map (fun {name; _} -> String.capitalize_ascii name) p.components)
src/lib_base/unix/protocol_files.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Definition name : string := "TEZOS_PROTOCOL" % string.
Import Protocol.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition to_file
(dirname : string) (hash : option Tezos_crypto.Protocol_hash.t)
(env_version : option Tezos_base__Protocol.env_version)
(modules : list string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let config_file :=
Data_encoding.Json.construct Meta.encoding
{| hash := hash; expected_env_version := env_version; modules := modules
|} in
Lwt_utils_unix.Json.write_file (op_divdiv dirname name) config_file.
Definition of_file (dirname : string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult Tezos_base.Protocol.Meta.t) :=
op_gtgteqquestion (Lwt_utils_unix.Json.read_file (op_divdiv dirname name))
(fun json => _return (Data_encoding.Json.destruct Meta.encoding json)).
Definition find_component (dirname : string) (module_name : string)
: Lwt.t Tezos_base.Protocol.component :=
let name_lowercase := Stdlib.String.uncapitalize_ascii module_name in
let implementation :=
String.append (op_divdiv dirname name_lowercase) ".ml" % string in
let interface := String.append implementation "i" % string in
match ((Sys.file_exists implementation), (Sys.file_exists interface)) with
| (false, _) =>
apply Pervasives.failwith
(String.append "Not such file: " % string implementation)
| (true, false) =>
op_gtpipeeq (Lwt_utils_unix.read_file implementation)
(fun implementation =>
{| name := module_name; interface := None;
implementation := implementation |})
| _ =>
op_gtgteq (Lwt_utils_unix.read_file interface)
(fun interface =>
op_gtpipeeq (Lwt_utils_unix.read_file implementation)
(fun implementation =>
{| name := module_name; interface := Some interface;
implementation := implementation |}))
end.
Definition read_dir (dir : string)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((option Tezos_crypto.Protocol_hash.t) * Tezos_base.Protocol.t)) :=
op_gtgteqquestion (of_file dir)
(fun meta =>
op_gtgteq (Lwt_list.map_p (find_component dir) (modules meta))
(fun components =>
let expected_env :=
match expected_env_version meta with
| None => Tezos_base.Protocol.V1
| Some v => v
end in
_return
((hash meta),
{| expected_env := expected_env; components := components |}))).
Import Lwt.Infix.
Definition create_files
(dir : string) (units : list Tezos_base.Protocol.component)
: Lwt.t (list string) :=
op_gtgteq (Lwt_utils_unix.remove_dir dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_utils_unix.create_dir None dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_list.map_s
(fun function_parameter =>
let '{|
name := name;
interface := interface;
implementation := implementation
|} := function_parameter in
let name := Stdlib.String.lowercase_ascii name in
let ml := op_divdiv dir (String.append name ".ml" % string) in
let mli := op_divdiv dir (String.append name ".mli" % string) in
op_gtgteq (Lwt_utils_unix.create_file None ml implementation)
(fun function_parameter =>
let 'tt := function_parameter in
match interface with
| None => Lwt._return (cons ml [])
| Some content =>
op_gtgteq (Lwt_utils_unix.create_file None mli content)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (cons mli (cons ml [])))
end)) units)
(fun files =>
let files := Stdlib.List.concat files in
Lwt._return files))).
Definition write_dir
(dir : string) (hash : option Tezos_crypto.Protocol_hash.t)
(p : Tezos_base.Protocol.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
op_gtgteq (create_files dir (components p))
(fun _files =>
to_file dir hash (Some (expected_env p))
(List.map
(fun function_parameter =>
let '{| name := name |} := function_parameter in
Stdlib.String.capitalize_ascii name) (components p))).
src/lib_clic/unix/scriptable.ml 7 errors
open Error_monad
type output_format = Rows of {separator : string; escape : [`No | `OCaml]}
let rows separator escape = Rows {separator; escape}
let tsv = rows "\t" `No
let csv = rows "," `OCaml
let clic_arg () =
let open Clic in
arg
~doc:"Make the output script-friendly"
~long:"for-script"
~placeholder:"FORMAT"
(parameter (fun _ spec ->
match String.lowercase_ascii spec with
| "tsv" ->
return tsv
| "csv" ->
return csv
| other ->
failwith
"Cannot recognize format %S, please try 'TSV' or 'CSV'"
other))
let fprintf_lwt chan fmt =
Format.kasprintf
(fun s ->
protect (fun () -> Lwt_io.write chan s >>= fun () -> return_unit))
fmt
let output ?(channel = Lwt_io.stdout) how_option ~for_human ~for_script =
match how_option with
| None ->
for_human ()
| Some (Rows {separator; escape}) ->
let open Format in
iter_s
(fun row ->
fprintf_lwt
channel
"%a@."
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt separator)
(fun fmt cell ->
match escape with
| `OCaml ->
fprintf fmt "%S" cell
| `No ->
pp_print_string fmt cell))
row)
(for_script ())
>>=? fun () ->
protect (fun () -> Lwt_io.flush channel >>= fun () -> return_unit)
let output_for_human how_option for_human =
output how_option ~for_human ~for_script:(fun () -> [])
let output_row ?channel how_option ~for_human ~for_script =
output ?channel how_option ~for_human ~for_script:(fun () -> [for_script ()])
src/lib_clic/unix/scriptable.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Inductive output_format : Type :=
| Rows : string -> variant -> output_format.
Definition rows (separator : string) (escape : variant) : output_format :=
Rows {| separator := separator; escape := escape |}.
Definition tsv : output_format :=
rows " " % string
(* ❌ Variants not supported *)
variant.
Definition csv : output_format :=
rows "," % string
(* ❌ Variants not supported *)
variant.
Definition clic_arg {A : Type} (function_parameter : unit)
: Tezos_clic.Clic.arg (option output_format) A :=
let 'tt := function_parameter in
arg "Make the output script-friendly" % string None "for-script" % string
"FORMAT" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun spec =>
match Stdlib.String.lowercase_ascii spec with
| "tsv" % string => _return tsv
| "csv" % string => _return csv
| other =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot recognize format " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
", please try 'TSV' or 'CSV'" % string
CamlinternalFormatBasics.End_of_format)))
"Cannot recognize format %S, please try 'TSV' or 'CSV'" % string)
other
end)).
Definition fprintf_lwt {A : Type}
(chan : Lwt_io.output_channel)
(fmt :
Stdlib.format4 A Stdlib.Format.formatter unit
(Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))) : A :=
Format.kasprintf
(fun s =>
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.write chan s)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) fmt.
Definition output (op_staroptstar : option Lwt_io.output_channel)
: (option output_format) ->
(unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ->
(unit -> list (list string)) ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let channel :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Lwt_io.stdout
end in
fun how_option =>
fun for_human =>
fun for_script =>
match how_option with
| None => for_human tt
| Some (Rows {| separator := separator; escape := escape |}) =>
op_gtgteqquestion
(iter_s
(fun row =>
fprintf_lwt channel
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)) "%a@." % string)
(pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
pp_print_string fmt separator))
(fun fmt =>
fun cell =>
match escape with
| OCaml =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)
"%S" % string) cell
| No => pp_print_string fmt cell
end)) row) (for_script tt))
(fun function_parameter =>
let 'tt := function_parameter in
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.flush channel)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
end.
Definition output_for_human
(how_option : option output_format)
(for_human : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
output None how_option for_human
(fun function_parameter =>
let 'tt := function_parameter in
[]).
Definition output_row
(channel : option Lwt_io.output_channel) (how_option : option output_format)
(for_human : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
(for_script : unit -> list string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
output channel how_option for_human
(fun function_parameter =>
let 'tt := function_parameter in
cons (for_script tt) []).
src/lib_client_base/client_aliases.ml 192 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Command line interface - Local Storage for Configuration *)
open Lwt.Infix
open Clic
module type Entity = sig
type t
val encoding : t Data_encoding.t
val of_source : string -> t tzresult Lwt.t
val to_source : t -> string tzresult Lwt.t
val name : string
end
module type Alias = sig
type t
type fresh_param
val load : #Client_context.wallet -> (string * t) list tzresult Lwt.t
val set : #Client_context.wallet -> (string * t) list -> unit tzresult Lwt.t
val find : #Client_context.wallet -> string -> t tzresult Lwt.t
val find_opt : #Client_context.wallet -> string -> t option tzresult Lwt.t
val rev_find : #Client_context.wallet -> t -> string option tzresult Lwt.t
val name : #Client_context.wallet -> t -> string tzresult Lwt.t
val mem : #Client_context.wallet -> string -> bool tzresult Lwt.t
val add :
force:bool -> #Client_context.wallet -> string -> t -> unit tzresult Lwt.t
val del : #Client_context.wallet -> string -> unit tzresult Lwt.t
val update : #Client_context.wallet -> string -> t -> unit tzresult Lwt.t
val of_source : string -> t tzresult Lwt.t
val to_source : t -> string tzresult Lwt.t
val alias_parameter :
unit -> (string * t, #Client_context.wallet) Clic.parameter
val alias_param :
?name:string ->
?desc:string ->
('a, (#Client_context.wallet as 'b)) Clic.params ->
(string * t -> 'a, 'b) Clic.params
val fresh_alias_param :
?name:string ->
?desc:string ->
('a, (< .. > as 'obj)) Clic.params ->
(fresh_param -> 'a, 'obj) Clic.params
val force_switch : unit -> (bool, _) arg
val of_fresh :
#Client_context.wallet -> bool -> fresh_param -> string tzresult Lwt.t
val source_param :
?name:string ->
?desc:string ->
('a, (#Client_context.wallet as 'obj)) Clic.params ->
(t -> 'a, 'obj) Clic.params
val source_arg :
?long:string ->
?placeholder:string ->
?doc:string ->
unit ->
(t option, (#Client_context.wallet as 'obj)) Clic.arg
val autocomplete : #Client_context.wallet -> string list tzresult Lwt.t
end
module Alias (Entity : Entity) = struct
open Client_context
let wallet_encoding : (string * Entity.t) list Data_encoding.encoding =
let open Data_encoding in
list (obj2 (req "name" string) (req "value" Entity.encoding))
let load (wallet : #wallet) =
wallet#load Entity.name ~default:[] wallet_encoding
let set (wallet : #wallet) entries =
wallet#write Entity.name entries wallet_encoding
let autocomplete wallet =
load wallet
>>= function
| Error _ -> return_nil | Ok list -> return (List.map fst list)
let find_opt (wallet : #wallet) name =
load wallet
>>=? fun list ->
try return_some (List.assoc name list) with Not_found -> return_none
let find (wallet : #wallet) name =
load wallet
>>=? fun list ->
try return (List.assoc name list)
with Not_found -> failwith "no %s alias named %s" Entity.name name
let rev_find (wallet : #wallet) v =
load wallet
>>=? fun list ->
try return_some (List.find (fun (_, v') -> v = v') list |> fst)
with Not_found -> return_none
let mem (wallet : #wallet) name =
load wallet
>>=? fun list ->
try
ignore (List.assoc name list) ;
return_true
with Not_found -> return_false
let add ~force (wallet : #wallet) name value =
let keep = ref false in
load wallet
>>=? fun list ->
( if force then return_unit
else
iter_s
(fun (n, v) ->
if n = name && v = value then (
keep := true ;
return_unit )
else if n = name && v <> value then
failwith
"another %s is already aliased as %s, use --force to update"
Entity.name
n
else if n <> name && v = value then
failwith
"this %s is already aliased as %s, use --force to insert \
duplicate"
Entity.name
n
else return_unit)
list )
>>=? fun () ->
let list = List.filter (fun (n, _) -> n <> name) list in
let list = (name, value) :: list in
if !keep then return_unit
else wallet#write Entity.name list wallet_encoding
let del (wallet : #wallet) name =
load wallet
>>=? fun list ->
let list = List.filter (fun (n, _) -> n <> name) list in
wallet#write Entity.name list wallet_encoding
let update (wallet : #wallet) name value =
load wallet
>>=? fun list ->
let list =
List.map (fun (n, v) -> (n, if n = name then value else v)) list
in
wallet#write Entity.name list wallet_encoding
include Entity
let alias_parameter () =
parameter ~autocomplete (fun cctxt s ->
find cctxt s >>=? fun v -> return (s, v))
let alias_param ?(name = "name")
?(desc = "existing " ^ Entity.name ^ " alias") next =
param ~name ~desc (alias_parameter ()) next
type fresh_param = Fresh of string
let of_fresh (wallet : #wallet) force (Fresh s) =
load wallet
>>=? fun list ->
( if force then return_unit
else
iter_s
(fun (n, v) ->
if n = s then
Entity.to_source v
>>=? fun value ->
failwith
"@[<v 2>The %s alias %s already exists.@,\
The current value is %s.@,\
Use --force to update@]"
Entity.name
n
value
else return_unit)
list )
>>=? fun () -> return s
let fresh_alias_param ?(name = "new")
?(desc = "new " ^ Entity.name ^ " alias") next =
param
~name
~desc
(parameter (fun (_ : < .. >) s -> return @@ Fresh s))
next
let parse_source_string cctxt s =
match String.split ~limit:1 ':' s with
| ["alias"; alias] ->
find cctxt alias
| ["text"; text] ->
of_source text
| ["file"; path] ->
cctxt#read_file path >>=? of_source
| _ -> (
find cctxt s
>>= function
| Ok v ->
return v
| Error a_errs -> (
cctxt#read_file s >>=? of_source
>>= function
| Ok v ->
return v
| Error r_errs -> (
of_source s
>>= function
| Ok v ->
return v
| Error s_errs ->
let all_errs = List.flatten [a_errs; r_errs; s_errs] in
Lwt.return_error all_errs ) ) )
let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
let desc =
Format.asprintf
"%s\n\
Can be a %s name, a file or a raw %s literal. If the parameter is \
not the name of an existing %s, the client will look for a file \
containing a %s, and if it does not exist, the argument will be read \
as a raw %s.\n\
Use 'alias:name', 'file:path' or 'text:literal' to disable autodetect."
desc
Entity.name
Entity.name
Entity.name
Entity.name
Entity.name
in
param ~name ~desc (parameter parse_source_string) next
let source_arg ?(long = "source " ^ Entity.name) ?(placeholder = "src")
?(doc = "") () =
let doc =
Format.asprintf
"%s\n\
Can be a %s name, a file or a raw %s literal. If the parameter is \
not the name of an existing %s, the client will look for a file \
containing a %s, and if it does not exist, the argument will be read \
as a raw %s.\n\
Use 'alias:name', 'file:path' or 'text:literal' to disable autodetect."
doc
Entity.name
Entity.name
Entity.name
Entity.name
Entity.name
in
arg ~long ~placeholder ~doc (parameter parse_source_string)
let force_switch () =
Clic.switch
~long:"force"
~short:'f'
~doc:("overwrite existing " ^ Entity.name)
()
let name (wallet : #wallet) d =
rev_find wallet d
>>=? function None -> Entity.to_source d | Some name -> return name
end
src/lib_client_base/client_aliases.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Import Clic.
Module Entity.
Record signature {t : Type} := {
t := t;
encoding : Tezos_base__TzPervasives.Data_encoding.t t;
of_source : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
to_source : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
name : string;
}.
Arguments signature : clear implicits.
End Entity.
Module Alias.
Record signature {t fresh_param : Type} := {
t := t;
fresh_param := fresh_param;
load : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list (string * t)));
set : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) ->
(list (string * t)) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
find_opt : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult (option t));
rev_find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option string));
name : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
mem : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult bool);
add : forall {_ a : Type}, bool ->
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
del : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
update : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
of_source : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
to_source : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
alias_parameter : forall {_ a : Type}, unit ->
Tezos_base__TzPervasives.Clic.parameter (string * t)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _);
alias_param : forall {a b : Type}, (option string) ->
(option string) ->
(Tezos_base__TzPervasives.Clic.params a
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
b))))) * b)) ->
Tezos_base__TzPervasives.Clic.params ((string * t) -> a)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
* b))))) * b);
fresh_alias_param : forall {a obj : Type}, (option string) ->
(option string) ->
(Tezos_base__TzPervasives.Clic.params a (obj)) ->
Tezos_base__TzPervasives.Clic.params (fresh_param -> a) (obj);
force_switch : forall {_ : Type}, unit ->
Tezos_base__TzPervasives.Clic.arg bool _;
of_fresh : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) ->
bool -> fresh_param -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
source_param : forall {a obj : Type}, (option string) ->
(option string) ->
(Tezos_base__TzPervasives.Clic.params a
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
obj))))) * obj)) ->
Tezos_base__TzPervasives.Clic.params (t -> a)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
* obj))))) * obj);
source_arg : forall {a obj : Type}, (option string) ->
(option string) ->
(option string) ->
unit ->
Tezos_base__TzPervasives.Clic.arg (option t)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) *
(a)) * obj))))) * obj);
autocomplete : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list string));
}.
Arguments signature : clear implicits.
End Alias.
(* ❌ Functors are not handled. *)
functor
src/lib_client_base/client_confirmations.ml 130 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let in_block operation_hash operations =
let exception Found of int * int in
try
List.iteri
(fun i ops ->
List.iteri
(fun j op ->
if Operation_hash.equal operation_hash op then raise (Found (i, j)))
ops)
operations ;
None
with Found (i, j) -> Some (i, j)
type operation_status =
| Confirmed of (Block_hash.t * int * int)
| Pending
| Still_not_found
let wait_for_operation_inclusion (ctxt : #Client_context.full) ~chain
?(predecessors = 10) ?(confirmations = 1) ?branch operation_hash =
let exception WrapError of error list in
let exception Outdated of Operation_hash.t in
(* Table of known blocks:
- None: if neither the block or its predecessors contains the operation
- (Some ((hash, i, j), n)):
if the `hash` contains the operation in list `i` at position `j`
and if `hash` denotes the `n-th` predecessors of the block. *)
let blocks : ((Block_hash.t * int * int) * int) option Block_hash.Table.t =
Block_hash.Table.create confirmations
in
(* Fetch _all_ the 'unknown' predecessors af a block. *)
let fetch_predecessors (hash, header) =
let rec loop acc (_hash, header) =
let predecessor = header.Block_header.predecessor in
if Block_hash.Table.mem blocks predecessor then return acc
else
Chain_services.Blocks.Header.shell_header
ctxt
~chain
~block:(`Hash (predecessor, 0))
()
>>=? fun shell ->
let block = (predecessor, shell) in
loop (block :: acc) block
in
loop [(hash, header.Block_header.shell)] (hash, header.shell)
>>= function
| Ok blocks ->
Lwt.return blocks
| Error err ->
ctxt#warning
"Error while fetching block (ignored): %a"
pp_print_error
err
>>= fun () ->
(* Will be retried when a new head arrives *)
Lwt.return_nil
in
(* Check whether a block as enough confirmations. This function
assumes that the block predecessor has been processed already. *)
let process hash header =
let block = `Hash (hash, 0) in
let predecessor = header.Tezos_base.Block_header.predecessor in
match Block_hash.Table.find blocks predecessor with
| Some (block_with_op, n) ->
ctxt#answer
"Operation received %d confirmations as of block: %a"
(n + 1)
Block_hash.pp
hash
>>= fun () ->
Block_hash.Table.add blocks hash (Some (block_with_op, n + 1)) ;
if n + 1 < confirmations then return Pending
else return (Confirmed block_with_op)
| None -> (
Shell_services.Blocks.Operation_hashes.operation_hashes
ctxt
~chain
~block
()
>>=? fun operations ->
match in_block operation_hash operations with
| None ->
Block_hash.Table.add blocks hash None ;
return Still_not_found
| Some (i, j) ->
ctxt#answer
"Operation found in block: %a (pass: %d, offset: %d)"
Block_hash.pp
hash
i
j
>>= fun () ->
Block_hash.Table.add blocks hash (Some ((hash, i, j), 0)) ;
if confirmations <= 0 then return (Confirmed (hash, i, j))
else return Pending )
in
(* Checks if the given branch is considered alive.*)
let check_branch_alive () =
match branch with
| Some branch_hash -> (
Shell_services.Blocks.live_blocks ctxt ~chain ~block:(`Head 0) ()
>>= function
| Ok live_blocks ->
if Block_hash.Set.mem branch_hash live_blocks then Lwt.return_unit
else
ctxt#error
"The operation %a is outdated and may never be included in \
the chain.@,\
We recommand to use an external block explorer."
Operation_hash.pp
operation_hash
>>= fun () -> Lwt.fail (Outdated operation_hash)
| Error err ->
Lwt.fail (WrapError err) )
| None ->
Lwt.return_unit
in
Shell_services.Monitor.heads ctxt chain
>>=? fun (stream, stop) ->
Lwt_stream.get stream
>>= function
| None ->
assert false
| Some (head, _) ->
let rec loop n =
if n >= 0 then
(*Search for the operation in the n head predecessors*)
let block = `Hash (head, n) in
Shell_services.Blocks.hash ctxt ~chain ~block ()
>>=? fun hash ->
Shell_services.Blocks.Header.shell_header ctxt ~chain ~block ()
>>=? fun shell ->
process hash shell
>>=? function
| Confirmed block ->
stop () ; return block
| Pending | Still_not_found ->
loop (n - 1)
else
(*Search for the operation in new heads*)
Lwt.catch
(fun () ->
(*Fetching potential unknown blocks from potential new heads*)
let stream = Lwt_stream.map_list_s fetch_predecessors stream in
Lwt_stream.find_s
(fun (hash, header) ->
process hash header
>>= function
| Ok Pending ->
Lwt.return_false
| Ok Still_not_found ->
check_branch_alive () >>= fun () -> Lwt.return_false
| Ok (Confirmed _) ->
Lwt.return_true
| Error err ->
Lwt.fail (WrapError err))
stream
>>= return)
(function
| WrapError e -> Lwt.return_error e | exn -> Lwt.fail exn)
>>=? function
| None ->
failwith "..."
| Some (hash, _) -> (
stop () ;
match Block_hash.Table.find_opt blocks hash with
| None | Some None ->
assert false
| Some (Some (hash, _)) ->
return hash )
in
( match branch with
| Some branch_hash ->
Shell_services.Blocks.Header.shell_header
ctxt
~chain
~block:(`Hash (branch_hash, 0))
()
>>=? fun branch_header ->
let branch_level = branch_header.Block_header.level in
Shell_services.Blocks.Header.shell_header
ctxt
~chain
~block:(`Hash (head, 0))
()
>>=? fun head_shell ->
let head_level = head_shell.Block_header.level in
return Int32.(to_int (sub head_level branch_level))
| None ->
return predecessors )
>>=? fun block_hook ->
Block_services.Empty.hash
ctxt
~chain
~block:(`Hash (head, block_hook + 1))
()
>>=? fun oldest ->
Block_hash.Table.add blocks oldest None ;
loop block_hook
let lookup_operation_in_previous_block ctxt chain operation_hash i =
Block_services.Empty.hash ctxt ~block:(`Head i) ()
>>=? fun block ->
Shell_services.Blocks.Operation_hashes.operation_hashes
ctxt
~chain
~block:(`Hash (block, 0))
()
>>=? fun operations ->
match in_block operation_hash operations with
| None ->
return_none
| Some (a, b) ->
return_some (block, a, b)
let lookup_operation_in_previous_blocks (ctxt : #Client_context.full) ~chain
~predecessors operation_hash =
let rec loop i =
if i = predecessors + 1 then return_none
else
lookup_operation_in_previous_block ctxt chain operation_hash i
>>=? function
| None -> loop (i + 1) | Some (block, a, b) -> return_some (block, a, b)
in
loop 0
let wait_for_bootstrapped (ctxt : #Client_context.full) =
let display = ref false in
Lwt.async (fun () ->
ctxt#sleep 0.3
>>= fun () ->
if not !display then (
ctxt#answer
"Waiting for the node to be bootstrapped before injection..."
>>= fun () ->
display := true ;
Lwt.return_unit )
else Lwt.return_unit) ;
Monitor_services.bootstrapped ctxt
>>=? fun (stream, _stop) ->
Lwt_stream.iter_s
(fun (hash, time) ->
if !display then
ctxt#message
"Current head: %a (timestamp: %a, validation: %a)"
Block_hash.pp_short
hash
Time.System.pp_hum
(Time.System.of_protocol_exn time)
Time.System.pp_hum
(ctxt#now ())
else Lwt.return_unit)
stream
>>= fun () ->
display := true ;
ctxt#answer "Node is bootstrapped, ready for injecting operations."
>>= fun () -> return_unit
src/lib_client_base/client_confirmations.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition in_block
(operation_hash : Tezos_base__TzPervasives.Operation_hash.t)
(operations : list (list Tezos_base__TzPervasives.Operation_hash.t))
: option (Z * Z) :=
(* ❌ Let of exception is not handled *)
let_exception.
Inductive operation_status : Type :=
| Confirmed : (Tezos_base__TzPervasives.Block_hash.t * Z * Z) ->
operation_status
| Pending : operation_status
| Still_not_found : operation_status.
Definition wait_for_operation_inclusion {F G I a b i o p q : Type}
(ctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (chain : Tezos_shell_services__Block_services.chain)
(op_staroptstar : option Z)
: (option Z) ->
(option Tezos_base__TzPervasives.Block_hash.Set.elt) ->
Tezos_base__TzPervasives.Operation_hash.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_hash.t * Z * Z)) :=
let predecessors :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 10
end in
fun op_staroptstar =>
let confirmations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 1
end in
fun branch =>
fun operation_hash =>
(* ❌ Let of exception is not handled *)
let_exception.
Definition lookup_operation_in_previous_block {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(chain : Tezos_shell_services__Block_services.chain)
(operation_hash : Tezos_base__TzPervasives.Operation_hash.t) (i : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
op_gtgteqquestion
(Block_services.Empty.hash ctxt None
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun block =>
op_gtgteqquestion
(Shell_services.Blocks.Operation_hashes.operation_hashes ctxt
(Some chain)
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun operations =>
match in_block operation_hash operations with
| None => return_none
| Some (a, b) => return_some (block, a, b)
end)).
Definition lookup_operation_in_previous_blocks {F G I a b i o p q : Type}
(ctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (chain : Tezos_shell_services__Block_services.chain)
(predecessors : Z)
(operation_hash : Tezos_base__TzPervasives.Operation_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
let fix loop (i : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
if equiv_decb i (Z.add predecessors 1) then
return_none
else
op_gtgteqquestion
(lookup_operation_in_previous_block ctxt chain operation_hash i)
(fun function_parameter =>
match function_parameter with
| None => loop (Z.add i 1)
| Some (block, a, b) => return_some (block, a, b)
end) in
loop 0.
Definition wait_for_bootstrapped {F G I a b i o p q : Type}
(ctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let display := Stdlib.ref false in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(* ❌ Float constant 0.3 is approximated by the integer 0 *)
0)
(fun function_parameter =>
let 'tt := function_parameter in
if negb (Stdlib.op_exclamation display) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Waiting for the node to be bootstrapped before injection..."
% string CamlinternalFormatBasics.End_of_format)
"Waiting for the node to be bootstrapped before injection..."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq display true in
Lwt.return_unit)
else
Lwt.return_unit)) in
op_gtgteqquestion (Monitor_services.bootstrapped ctxt)
(fun function_parameter =>
let '(stream, _stop) := function_parameter in
op_gtgteq
(Lwt_stream.iter_s
(fun function_parameter =>
let '(hash, time) := function_parameter in
if Stdlib.op_exclamation display then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Current head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (timestamp: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", validation: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Current head: %a (timestamp: %a, validation: %a)" % string)
Block_hash.pp_short hash Time.System.pp_hum
(Time.System.of_protocol_exn time) Time.System.pp_hum
((* ❌ Sending method message is not handled *)
send tt)
else
Lwt.return_unit) stream)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq display true in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Node is bootstrapped, ready for injecting operations." %
string CamlinternalFormatBasics.End_of_format)
"Node is bootstrapped, ready for injecting operations." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
src/lib_client_base/client_context.ml 26 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4
class type printer =
object
method error : ('a, 'b) lwt_format -> 'a
method warning : ('a, unit) lwt_format -> 'a
method message : ('a, unit) lwt_format -> 'a
method answer : ('a, unit) lwt_format -> 'a
method log : string -> ('a, unit) lwt_format -> 'a
end
class type prompter =
object
method prompt : ('a, string tzresult) lwt_format -> 'a
method prompt_password : ('a, Bigstring.t tzresult) lwt_format -> 'a
end
class type io =
object
inherit printer
inherit prompter
end
class simple_printer log =
let message x = Format.kasprintf (fun msg -> log "stdout" msg) x in
object
method error : type a b. (a, b) lwt_format -> a =
Format.kasprintf (fun msg -> Lwt.fail (Failure msg))
method warning : type a. (a, unit) lwt_format -> a =
Format.kasprintf (fun msg -> log "stderr" msg)
method message : type a. (a, unit) lwt_format -> a = message
method answer : type a. (a, unit) lwt_format -> a = message
method log : type a. string -> (a, unit) lwt_format -> a =
fun name -> Format.kasprintf (fun msg -> log name msg)
end
class type wallet =
object
method load_passwords : string Lwt_stream.t option
method read_file : string -> string tzresult Lwt.t
method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t
method load :
string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t
method write :
string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
end
class type chain =
object
method chain : Shell_services.chain
end
class type block =
object
method block : Shell_services.block
method confirmations : int option
end
class type io_wallet =
object
inherit printer
inherit prompter
inherit wallet
end
class type io_rpcs =
object
inherit printer
inherit prompter
inherit RPC_context.json
end
class type ui =
object
method sleep : float -> unit Lwt.t
method now : unit -> Ptime.t
end
class type full =
object
inherit printer
inherit prompter
inherit wallet
inherit RPC_context.json
inherit chain
inherit block
inherit ui
end
class proxy_context (obj : full) =
object
method load_passwords = obj#load_passwords
method read_file = obj#read_file
method base = obj#base
method chain = obj#chain
method block = obj#block
method confirmations = obj#confirmations
method answer : type a. (a, unit) lwt_format -> a = obj#answer
method call_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
'q -> 'i -> 'o tzresult Lwt.t =
obj#call_service
method call_streamed_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
(unit -> unit) tzresult Lwt.t =
obj#call_streamed_service
method error : type a b. (a, b) lwt_format -> a = obj#error
method generic_json_call = obj#generic_json_call
method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = obj#with_lock
method load : type a.
string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
obj#load
method log : type a. string -> (a, unit) lwt_format -> a = obj#log
method message : type a. (a, unit) lwt_format -> a = obj#message
method warning : type a. (a, unit) lwt_format -> a = obj#warning
method write : type a.
string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
obj#write
method prompt : type a. (a, string tzresult) lwt_format -> a = obj#prompt
method prompt_password : type a. (a, Bigstring.t tzresult) lwt_format -> a
=
obj#prompt_password
method sleep : float -> unit Lwt.t = obj#sleep
method now : unit -> Ptime.t = obj#now
end
let log _ _ = Lwt.return_unit
let null_printer : #printer = new simple_printer log
src/lib_client_base/client_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition lwt_format (a b : Type) :=
Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t b).
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class` not handled. *)
class
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class` not handled. *)
class
Definition log {A B : Type} (function_parameter : A) : B -> Lwt.t unit :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit.
Definition null_printer {a b : Type}
: ((((lwt_format a b) -> a) * (a * b)) *
((((lwt_format a unit) -> a) * (a)) *
((((lwt_format a unit) -> a) * (a)) *
((((lwt_format a unit) -> a) * (a)) *
(((string -> (lwt_format a unit) -> a) * (a)) * nil))))) * nil :=
(* ❌ Creation of new objects is not handled *)
new log.
src/lib_client_base/client_keys.ml 113 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type error += Unregistered_key_scheme of string
type error += Invalid_uri of Uri.t
let () =
register_error_kind
`Permanent
~id:"cli.unregistered_key_scheme"
~title:"Unregistered key scheme"
~description:
"A key has been provided with an unregistered scheme (no corresponding \
plugin)"
~pp:(fun ppf s ->
Format.fprintf ppf "No matching plugin for key scheme %s" s)
Data_encoding.(obj1 (req "value" string))
(function Unregistered_key_scheme s -> Some s | _ -> None)
(fun s -> Unregistered_key_scheme s) ;
register_error_kind
`Permanent
~id:"cli.key.invalid_uri"
~title:"Invalid key uri"
~description:"A key has been provided with an invalid uri."
~pp:(fun ppf s -> Format.fprintf ppf "Cannot parse the key uri: %s" s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_uri s -> Some (Uri.to_string s) | _ -> None)
(fun s -> Invalid_uri (Uri.of_string s))
module Public_key_hash = struct
include Client_aliases.Alias (struct
type t = Signature.Public_key_hash.t
let encoding = Signature.Public_key_hash.encoding
let of_source s = Lwt.return (Signature.Public_key_hash.of_b58check s)
let to_source p = return (Signature.Public_key_hash.to_b58check p)
let name = "public key hash"
end)
end
module Logging = struct
let tag = Tag.def ~doc:"Identity" "pk_alias" Format.pp_print_text
end
let uri_encoding = Data_encoding.(conv Uri.to_string Uri.of_string string)
type pk_uri = Uri.t
let make_pk_uri (x : Uri.t) : pk_uri =
match Uri.scheme x with
| None ->
Pervasives.failwith "PK_URI needs a scheme"
| Some _ ->
x
type sk_uri = Uri.t
let make_sk_uri (x : Uri.t) : sk_uri =
match Uri.scheme x with
| None ->
Pervasives.failwith "SK_URI needs a scheme"
| Some _ ->
x
let pk_uri_parameter () =
Clic.parameter (fun _ s ->
try return (make_pk_uri @@ Uri.of_string s)
with Failure s -> failwith "Error while parsing URI: %s" s)
let pk_uri_param ?name ?desc params =
let name = Option.unopt ~default:"uri" name in
let desc =
Option.unopt
~default:
"public key\n\
Varies from one scheme to the other.\n\
Use command `list signing schemes` for more information."
desc
in
Clic.param ~name ~desc (pk_uri_parameter ()) params
let sk_uri_parameter () =
Clic.parameter (fun _ s ->
try return (make_sk_uri @@ Uri.of_string s)
with Failure s -> failwith "Error while parsing URI: %s" s)
let sk_uri_param ?name ?desc params =
let name = Option.unopt ~default:"uri" name in
let desc =
Option.unopt
~default:
"secret key\n\
Varies from one scheme to the other.\n\
Use command `list signing schemes` for more information."
desc
in
Clic.param ~name ~desc (sk_uri_parameter ()) params
module Secret_key = Client_aliases.Alias (struct
let name = "secret_key"
type t = Uri.t
let of_source s = return (Uri.of_string s)
let to_source t = return (Uri.to_string t)
let encoding = uri_encoding
end)
module Public_key = Client_aliases.Alias (struct
let name = "public_key"
type t = Uri.t * Signature.Public_key.t option
let of_source s = return (Uri.of_string s, None)
let to_source (t, _) = return (Uri.to_string t)
let encoding =
let open Data_encoding in
union
[ case
Json_only
~title:"Locator_only"
uri_encoding
(function (uri, None) -> Some uri | (_, Some _) -> None)
(fun uri -> (uri, None));
case
Json_only
~title:"Locator_and_full_key"
(obj2
(req "locator" uri_encoding)
(req "key" Signature.Public_key.encoding))
(function (uri, Some key) -> Some (uri, key) | (_, None) -> None)
(fun (uri, key) -> (uri, Some key)) ]
end)
module type SIGNER = sig
val scheme : string
val title : string
val description : string
val neuterize : sk_uri -> pk_uri tzresult Lwt.t
val import_secret_key :
io:Client_context.io_wallet ->
pk_uri ->
(Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
Lwt.t
val public_key : pk_uri -> Signature.Public_key.t tzresult Lwt.t
val public_key_hash :
pk_uri ->
(Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
Lwt.t
val sign :
?watermark:Signature.watermark ->
sk_uri ->
Bytes.t ->
Signature.t tzresult Lwt.t
val deterministic_nonce : sk_uri -> Bytes.t -> Bigstring.t tzresult Lwt.t
val deterministic_nonce_hash : sk_uri -> Bytes.t -> Bytes.t tzresult Lwt.t
val supports_deterministic_nonces : sk_uri -> bool tzresult Lwt.t
end
let signers_table : (string, (module SIGNER)) Hashtbl.t = Hashtbl.create 13
let register_signer signer =
let module Signer = (val signer : SIGNER) in
Hashtbl.replace signers_table Signer.scheme signer
let find_signer_for_key ~scheme =
match Hashtbl.find_opt signers_table scheme with
| None ->
fail (Unregistered_key_scheme scheme)
| Some signer ->
return signer
let registered_signers () : (string * (module SIGNER)) list =
Hashtbl.fold (fun k v acc -> (k, v) :: acc) signers_table []
type error += Signature_mismatch of sk_uri
let () =
register_error_kind
`Permanent
~id:"cli.signature_mismatch"
~title:"Signature mismatch"
~description:"The signer produced an invalid signature"
~pp:(fun ppf sk ->
Format.fprintf
ppf
"The signer for %a produced an invalid signature"
Uri.pp_hum
sk)
Data_encoding.(obj1 (req "locator" uri_encoding))
(function Signature_mismatch sk -> Some sk | _ -> None)
(fun sk -> Signature_mismatch sk)
let with_scheme_signer (uri : Uri.t) (f : (module SIGNER) -> 'a) : 'a =
match Uri.scheme uri with
| None ->
assert false
| Some scheme ->
find_signer_for_key ~scheme >>=? fun signer -> f signer
let neuterize sk_uri =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.neuterize sk_uri)
let public_key pk_uri =
with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
Signer.public_key pk_uri)
let public_key_hash pk_uri =
with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
Signer.public_key_hash pk_uri)
let import_secret_key ~io pk_uri =
with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
Signer.import_secret_key ~io pk_uri)
let sign cctxt ?watermark sk_uri buf =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.sign ?watermark sk_uri buf
>>=? fun signature ->
Signer.neuterize sk_uri
>>=? fun pk_uri ->
Secret_key.rev_find cctxt sk_uri
>>=? (function
| None ->
public_key pk_uri
| Some name -> (
Public_key.find cctxt name
>>=? function
| (_, None) ->
public_key pk_uri
>>=? fun pk ->
Public_key.update cctxt name (pk_uri, Some pk)
>>=? fun () -> return pk
| (_, Some pubkey) ->
return pubkey ))
>>=? fun pubkey ->
fail_unless
(Signature.check ?watermark pubkey signature buf)
(Signature_mismatch sk_uri)
>>=? fun () -> return signature)
let append cctxt ?watermark loc buf =
sign cctxt ?watermark loc buf
>>|? fun signature -> Signature.concat buf signature
let check ?watermark pk_uri signature buf =
public_key pk_uri
>>=? fun pk -> return (Signature.check ?watermark pk signature buf)
let deterministic_nonce sk_uri data =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.deterministic_nonce sk_uri data)
let deterministic_nonce_hash sk_uri data =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.deterministic_nonce_hash sk_uri data)
let supports_deterministic_nonces sk_uri =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.supports_deterministic_nonces sk_uri)
let register_key cctxt ?(force = false) (public_key_hash, pk_uri, sk_uri)
?public_key name =
Public_key.add ~force cctxt name (pk_uri, public_key)
>>=? fun () ->
Secret_key.add ~force cctxt name sk_uri
>>=? fun () ->
Public_key_hash.add ~force cctxt name public_key_hash
>>=? fun () -> return_unit
let raw_get_key (cctxt : #Client_context.wallet) pkh =
Public_key_hash.rev_find cctxt pkh
>>=? (function
| None ->
failwith "no keys for the source contract manager"
| Some n ->
Secret_key.find_opt cctxt n
>>=? fun sk_uri ->
Public_key.find_opt cctxt n
>>=? (function
| None ->
return_none
| Some (_, Some pk) ->
return_some pk
| Some (pk_uri, None) ->
public_key pk_uri
>>=? fun pk ->
Public_key.update cctxt n (pk_uri, Some pk)
>>=? fun () -> return_some pk)
>>=? fun pk -> return (n, pk, sk_uri))
>>= function
| (Ok (_, None, None) | Error _) as initial_result -> (
(* try to lookup for a remote key *)
find_signer_for_key ~scheme:"remote"
>>=? (fun signer ->
let module Signer = (val signer : SIGNER) in
let path = Signature.Public_key_hash.to_b58check pkh in
let uri = Uri.make ~scheme:Signer.scheme ~path () in
Signer.public_key uri
>>=? fun pk -> return (path, Some pk, Some uri))
>>= function
| Error _ ->
Lwt.return initial_result
| Ok _ as success ->
Lwt.return success )
| Ok _ as success ->
Lwt.return success
let get_key cctxt pkh =
raw_get_key cctxt pkh
>>=? function
| (pkh, Some pk, Some sk) ->
return (pkh, pk, sk)
| (_pkh, _pk, None) ->
failwith "Unknown secret key for %a" Signature.Public_key_hash.pp pkh
| (_pkh, None, _sk) ->
failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh
let get_public_key cctxt pkh =
raw_get_key cctxt pkh
>>=? function
| (pkh, Some pk, _sk) ->
return (pkh, pk)
| (_pkh, None, _sk) ->
failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh
let get_keys (cctxt : #Client_context.wallet) =
Secret_key.load cctxt
>>=? fun sks ->
Lwt_list.filter_map_s
(fun (name, sk_uri) ->
Public_key_hash.find cctxt name
>>=? (fun pkh ->
Public_key.find cctxt name
>>=? (function
| (_, Some pk) ->
return pk
| (pk_uri, None) ->
public_key pk_uri
>>=? fun pk ->
Public_key.update cctxt name (pk_uri, Some pk)
>>=? fun () -> return pk)
>>=? fun pk -> return (name, pkh, pk, sk_uri))
>>= function Ok r -> Lwt.return_some r | Error _ -> Lwt.return_none)
sks
>>= fun keys -> return keys
let list_keys cctxt =
Public_key_hash.load cctxt
>>=? fun l ->
map_s
(fun (name, pkh) ->
raw_get_key cctxt pkh
>>= function
| Ok (_name, pk, sk_uri) ->
return (name, pkh, pk, sk_uri)
| Error _ ->
return (name, pkh, None, None))
l
let alias_keys cctxt name =
Public_key_hash.find cctxt name
>>=? fun pkh ->
raw_get_key cctxt pkh
>>= function
| Ok (_name, pk, sk_uri) ->
return_some (pkh, pk, sk_uri)
| Error _ ->
return_none
let force_switch () =
Clic.switch ~long:"force" ~short:'f' ~doc:"overwrite existing keys" ()
src/lib_client_base/client_keys.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Module Public_key_hash.
(* ❌ Structure item `include` not handled. *)
include
End Public_key_hash.
Module Logging.
Definition tag : Tezos_base__TzPervasives.Tag.def string :=
Tag.def (Some "Identity" % string) "pk_alias" % string Format.pp_print_text.
End Logging.
Definition uri_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Uri.t :=
conv Uri.to_string Uri.of_string None string.
Definition pk_uri := Uri.t.
Definition make_pk_uri (x : Uri.t) : pk_uri :=
match Uri.scheme x with
| None => Pervasives.failwith "PK_URI needs a scheme" % string
| Some _ => x
end.
Definition sk_uri := Uri.t.
Definition make_sk_uri (x : Uri.t) : sk_uri :=
match Uri.scheme x with
| None => Pervasives.failwith "SK_URI needs a scheme" % string
| Some _ => x
end.
Definition pk_uri_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter pk_uri A :=
let 'tt := function_parameter in
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (apply make_pk_uri (Uri.of_string s)))).
Definition pk_uri_param {A B : Type}
(name : option string) (desc : option string)
(params : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params (pk_uri -> A) B :=
let name := Option.unopt "uri" % string name in
let desc :=
Option.unopt
"public key
Varies from one scheme to the other.
Use command `list signing schemes` for more information."
% string desc in
Clic.param name desc (pk_uri_parameter tt) params.
Definition sk_uri_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter sk_uri A :=
let 'tt := function_parameter in
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (apply make_sk_uri (Uri.of_string s)))).
Definition sk_uri_param {A B : Type}
(name : option string) (desc : option string)
(params : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params (sk_uri -> A) B :=
let name := Option.unopt "uri" % string name in
let desc :=
Option.unopt
"secret key
Varies from one scheme to the other.
Use command `list signing schemes` for more information."
% string desc in
Clic.param name desc (sk_uri_parameter tt) params.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module SIGNER.
Record signature := {
scheme : string;
title : string;
description : string;
neuterize : sk_uri -> Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri);
import_secret_key : Tezos_client_base.Client_context.io_wallet ->
pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t)));
public_key : pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Public_key.t);
public_key_hash : pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t)));
sign : (option Tezos_base__TzPervasives.Signature.watermark) ->
sk_uri ->
Stdlib.Bytes.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.t);
deterministic_nonce : sk_uri ->
Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t);
deterministic_nonce_hash : sk_uri ->
Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t);
supports_deterministic_nonces : sk_uri ->
Lwt.t (Tezos_base__TzPervasives.tzresult bool);
}.
End SIGNER.
Definition signers_table
: Stdlib.Hashtbl.t string {_ : unit & SIGNER.signature } :=
Hashtbl.create None 13.
Definition register_signer (signer : {_ : unit & SIGNER.signature }) : unit :=
let Signer := projT2 signer in
Hashtbl.replace signers_table Signer.(SIGNER.scheme) signer.
Definition find_signer_for_key (scheme : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult {_ : unit & SIGNER.signature }) :=
match Hashtbl.find_opt signers_table scheme with
| None => fail (Tezos_base__TzPervasives.Unregistered_key_scheme scheme)
| Some signer => _return signer
end.
Definition registered_signers (function_parameter : unit)
: list (string * {_ : unit & SIGNER.signature }) :=
let 'tt := function_parameter in
Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc) signers_table [].
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition with_scheme_signer {A : Type}
(uri : Uri.t)
(f :
{_ : unit & SIGNER.signature } ->
Lwt.t (Tezos_base__TzPervasives.tzresult A))
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
match Uri.scheme uri with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some scheme =>
op_gtgteqquestion (find_signer_for_key scheme) (fun signer => f signer)
end.
Definition neuterize (sk_uri : sk_uri)
: Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.neuterize) sk_uri).
Definition public_key (pk_uri : pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Public_key.t) :=
with_scheme_signer pk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.public_key) pk_uri).
Definition public_key_hash (pk_uri : pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
with_scheme_signer pk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.public_key_hash) pk_uri).
Definition import_secret_key
(io : Tezos_client_base.Client_context.io_wallet) (pk_uri : pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
with_scheme_signer pk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.import_secret_key) io pk_uri).
Definition sign {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (watermark : option Tezos_base__TzPervasives.Signature.watermark)
(sk_uri : sk_uri) (buf : Stdlib.Bytes.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
op_gtgteqquestion (Signer.(SIGNER.sign) watermark sk_uri buf)
(fun signature =>
op_gtgteqquestion (Signer.(SIGNER.neuterize) sk_uri)
(fun pk_uri =>
op_gtgteqquestion
(op_gtgteqquestion (Secret_key.rev_find cctxt sk_uri)
(fun function_parameter =>
match function_parameter with
| None => public_key pk_uri
| Some name =>
op_gtgteqquestion (Public_key.find cctxt name)
(fun function_parameter =>
match function_parameter with
| (_, None) =>
op_gtgteqquestion (public_key pk_uri)
(fun pk =>
op_gtgteqquestion
(Public_key.update cctxt name
(pk_uri, (Some pk)))
(fun function_parameter =>
let 'tt := function_parameter in
_return pk))
| (_, Some pubkey) => _return pubkey
end)
end))
(fun pubkey =>
op_gtgteqquestion
(fail_unless
(Signature.check watermark pubkey signature buf)
(Tezos_base__TzPervasives.Signature_mismatch sk_uri))
(fun function_parameter =>
let 'tt := function_parameter in
_return signature))))).
Definition append {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (watermark : option Tezos_base__TzPervasives.Signature.watermark)
(loc : sk_uri) (buf : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
op_gtgtpipequestion (sign cctxt watermark loc buf)
(fun signature => Signature.concat buf signature).
Definition check
(watermark : option Tezos_base__TzPervasives.Signature.watermark)
(pk_uri : pk_uri) (signature : Tezos_base__TzPervasives.Signature.t)
(buf : Stdlib.Bytes.t) : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
op_gtgteqquestion (public_key pk_uri)
(fun pk => _return (Signature.check watermark pk signature buf)).
Definition deterministic_nonce (sk_uri : sk_uri) (data : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.deterministic_nonce) sk_uri data).
Definition deterministic_nonce_hash (sk_uri : sk_uri) (data : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.deterministic_nonce_hash) sk_uri data).
Definition supports_deterministic_nonces (sk_uri : sk_uri)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.supports_deterministic_nonces) sk_uri).
Definition register_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (op_staroptstar : option bool)
: (Public_key_hash.t * Uri.t * Secret_key.t) ->
(option Tezos_base__TzPervasives.Signature.Public_key.t) ->
string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun function_parameter =>
let '(public_key_hash, pk_uri, sk_uri) := function_parameter in
fun public_key =>
fun name =>
op_gtgteqquestion (Public_key.add force cctxt name (pk_uri, public_key))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Secret_key.add force cctxt name sk_uri)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Public_key_hash.add force cctxt name public_key_hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition raw_get_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Public_key_hash.t)
: Lwt.t
(sum
(string * (option Tezos_base__TzPervasives.Signature.Public_key.t) *
(option Secret_key.t)) Tezos_base__TzPervasives.trace) :=
op_gtgteq
(op_gtgteqquestion (Public_key_hash.rev_find cctxt pkh)
(fun function_parameter =>
match function_parameter with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"no keys for the source contract manager" % string
CamlinternalFormatBasics.End_of_format)
"no keys for the source contract manager" % string)
| Some n =>
op_gtgteqquestion (Secret_key.find_opt cctxt n)
(fun sk_uri =>
op_gtgteqquestion
(op_gtgteqquestion (Public_key.find_opt cctxt n)
(fun function_parameter =>
match function_parameter with
| None => return_none
| Some (_, Some pk) => return_some pk
| Some (pk_uri, None) =>
op_gtgteqquestion (public_key pk_uri)
(fun pk =>
op_gtgteqquestion
(Public_key.update cctxt n (pk_uri, (Some pk)))
(fun function_parameter =>
let 'tt := function_parameter in
return_some pk))
end)) (fun pk => _return (n, pk, sk_uri)))
end))
(fun function_parameter =>
match function_parameter with
| (Stdlib.Ok (_, None, None) | Stdlib.Error _) as initial_result =>
op_gtgteq
(op_gtgteqquestion (find_signer_for_key "remote" % string)
(fun signer =>
let Signer := projT2 signer in
let path := Signature.Public_key_hash.to_b58check pkh in
let uri :=
Uri.make (Some Signer.(SIGNER.scheme)) None None None
(Some path) None None tt in
op_gtgteqquestion (Signer.(SIGNER.public_key) uri)
(fun pk => _return (path, (Some pk), (Some uri)))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ => Lwt._return initial_result
| (Stdlib.Ok _) as success => Lwt._return success
end)
| (Stdlib.Ok _) as success => Lwt._return success
end).
Definition get_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(string * Tezos_base__TzPervasives.Signature.Public_key.t * Secret_key.t)) :=
op_gtgteqquestion (raw_get_key cctxt pkh)
(fun function_parameter =>
match function_parameter with
| (pkh, Some pk, Some sk) => _return (pkh, pk, sk)
| (_pkh, _pk, None) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown secret key for " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Unknown secret key for %a" % string) Signature.Public_key_hash.pp
pkh
| (_pkh, None, _sk) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown public key for " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Unknown public key for %a" % string) Signature.Public_key_hash.pp
pkh
end).
Definition get_public_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(string * Tezos_base__TzPervasives.Signature.Public_key.t)) :=
op_gtgteqquestion (raw_get_key cctxt pkh)
(fun function_parameter =>
match function_parameter with
| (pkh, Some pk, _sk) => _return (pkh, pk)
| (_pkh, None, _sk) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown public key for " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Unknown public key for %a" % string) Signature.Public_key_hash.pp
pkh
end).
Definition get_keys {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(string * Public_key_hash.t *
Tezos_base__TzPervasives.Signature.Public_key.t * Secret_key.t))) :=
op_gtgteqquestion (Secret_key.load cctxt)
(fun sks =>
op_gtgteq
(Lwt_list.filter_map_s
(fun function_parameter =>
let '(name, sk_uri) := function_parameter in
op_gtgteq
(op_gtgteqquestion (Public_key_hash.find cctxt name)
(fun pkh =>
op_gtgteqquestion
(op_gtgteqquestion (Public_key.find cctxt name)
(fun function_parameter =>
match function_parameter with
| (_, Some pk) => _return pk
| (pk_uri, None) =>
op_gtgteqquestion (public_key pk_uri)
(fun pk =>
op_gtgteqquestion
(Public_key.update cctxt name
(pk_uri, (Some pk)))
(fun function_parameter =>
let 'tt := function_parameter in
_return pk))
end)) (fun pk => _return (name, pkh, pk, sk_uri))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok r => Lwt.return_some r
| Stdlib.Error _ => Lwt.return_none
end)) sks) (fun keys => _return keys)).
Definition list_keys {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(string * Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t) *
(option Secret_key.t)))) :=
op_gtgteqquestion (Public_key_hash.load cctxt)
(fun l =>
map_s
(fun function_parameter =>
let '(name, pkh) := function_parameter in
op_gtgteq (raw_get_key cctxt pkh)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (_name, pk, sk_uri) => _return (name, pkh, pk, sk_uri)
| Stdlib.Error _ => _return (name, pkh, None, None)
end)) l).
Definition alias_keys {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (name : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option
(Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t) *
(option Secret_key.t)))) :=
op_gtgteqquestion (Public_key_hash.find cctxt name)
(fun pkh =>
op_gtgteq (raw_get_key cctxt pkh)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (_name, pk, sk_uri) => return_some (pkh, pk, sk_uri)
| Stdlib.Error _ => return_none
end)).
Definition force_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
Clic.switch "overwrite existing keys" % string (Some "f" % char)
"force" % string tt.
src/lib_client_base_unix/client_config.ml 323 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Command line interface - Configuration and Arguments Parsing *)
type error += Invalid_chain_argument of string
type error += Invalid_block_argument of string
type error += Invalid_protocol_argument of string
type error += Invalid_port_arg of string
type error += Invalid_remote_signer_argument of string
type error += Invalid_wait_arg of string
let () =
register_error_kind
`Branch
~id:"badChainArgument"
~title:"Bad Chain Argument"
~description:"Chain argument could not be parsed"
~pp:(fun ppf s ->
Format.fprintf ppf "Value %s is not a value chain reference." s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_chain_argument s -> Some s | _ -> None)
(fun s -> Invalid_chain_argument s) ;
register_error_kind
`Branch
~id:"badBlockArgument"
~title:"Bad Block Argument"
~description:"Block argument could not be parsed"
~pp:(fun ppf s ->
Format.fprintf ppf "Value %s is not a value block reference." s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_block_argument s -> Some s | _ -> None)
(fun s -> Invalid_block_argument s) ;
register_error_kind
`Branch
~id:"badProtocolArgument"
~title:"Bad Protocol Argument"
~description:"Protocol argument could not be parsed"
~pp:(fun ppf s ->
Format.fprintf
ppf
"Value %s does not correspond to any known protocol."
s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_protocol_argument s -> Some s | _ -> None)
(fun s -> Invalid_protocol_argument s) ;
register_error_kind
`Branch
~id:"invalidPortArgument"
~title:"Bad Port Argument"
~description:"Port argument could not be parsed"
~pp:(fun ppf s -> Format.fprintf ppf "Value %s is not a valid TCP port." s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_port_arg s -> Some s | _ -> None)
(fun s -> Invalid_port_arg s) ;
register_error_kind
`Branch
~id:"invalid_remote_signer_argument"
~title:"Unexpected URI of remote signer"
~description:"The remote signer argument could not be parsed"
~pp:(fun ppf s -> Format.fprintf ppf "Value '%s' is not a valid URI." s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_remote_signer_argument s -> Some s | _ -> None)
(fun s -> Invalid_remote_signer_argument s) ;
register_error_kind
`Branch
~id:"invalidWaitArgument"
~title:"Bad Wait Argument"
~description:"Wait argument could not be parsed"
~pp:(fun ppf s ->
Format.fprintf
ppf
"Value %s is not a valid number of confirmation, nor 'none'."
s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_wait_arg s -> Some s | _ -> None)
(fun s -> Invalid_wait_arg s)
let home = try Sys.getenv "HOME" with Not_found -> "/root"
let default_base_dir = Filename.concat home ".tezos-client"
let default_chain = `Main
let default_block = `Head 0
let ( // ) = Filename.concat
module Cfg_file = struct
type t = {
base_dir : string;
node_addr : string;
node_port : int;
tls : bool;
web_port : int;
remote_signer : Uri.t option;
confirmations : int option;
password_filename : string option;
}
let default =
{
base_dir = default_base_dir;
node_addr = "localhost";
node_port = 8732;
tls = false;
web_port = 8080;
remote_signer = None;
confirmations = Some 0;
password_filename = None;
}
open Data_encoding
let encoding =
conv
(fun { base_dir;
node_addr;
node_port;
tls;
web_port;
remote_signer;
confirmations;
password_filename } ->
( base_dir,
Some node_addr,
Some node_port,
Some tls,
Some web_port,
remote_signer,
confirmations,
password_filename ))
(fun ( base_dir,
node_addr,
node_port,
tls,
web_port,
remote_signer,
confirmations,
password_filename ) ->
let node_addr = Option.unopt ~default:default.node_addr node_addr in
let node_port = Option.unopt ~default:default.node_port node_port in
let tls = Option.unopt ~default:default.tls tls in
let web_port = Option.unopt ~default:default.web_port web_port in
{
base_dir;
node_addr;
node_port;
tls;
web_port;
remote_signer;
confirmations;
password_filename;
})
(obj8
(req "base_dir" string)
(opt "node_addr" string)
(opt "node_port" int16)
(opt "tls" bool)
(opt "web_port" int16)
(opt "remote_signer" RPC_encoding.uri_encoding)
(opt "confirmations" int8)
(opt "password_filename" string))
let from_json json = Data_encoding.Json.destruct encoding json
let read fp =
Lwt_utils_unix.Json.read_file fp >>=? fun json -> return (from_json json)
let write out cfg =
Lwt_utils_unix.Json.write_file
out
(Data_encoding.Json.construct encoding cfg)
end
type cli_args = {
chain : Chain_services.chain;
block : Shell_services.block;
confirmations : int option;
password_filename : string option;
protocol : Protocol_hash.t option;
print_timings : bool;
log_requests : bool;
}
let default_cli_args =
{
chain = default_chain;
block = default_block;
confirmations = Some 0;
password_filename = None;
protocol = None;
print_timings = false;
log_requests = false;
}
open Clic
let string_parameter () : (string, #Client_context.full) parameter =
parameter (fun _ x -> return x)
let chain_parameter () =
parameter (fun _ chain ->
match Chain_services.parse_chain chain with
| Error _ ->
fail (Invalid_chain_argument chain)
| Ok chain ->
return chain)
let block_parameter () =
parameter (fun _ block ->
match Block_services.parse_block block with
| Error _ ->
fail (Invalid_block_argument block)
| Ok block ->
return block)
let wait_parameter () =
parameter (fun _ wait ->
match wait with
| "no" | "none" ->
return_none
| _ -> (
try
let w = int_of_string wait in
if 0 <= w then return_some w else fail (Invalid_wait_arg wait)
with _ -> fail (Invalid_wait_arg wait) ))
let protocol_parameter () =
parameter (fun _ arg ->
try
let (hash, _commands) =
List.find
(fun (hash, _commands) ->
String.has_prefix ~prefix:arg (Protocol_hash.to_b58check hash))
(Client_commands.get_versions ())
in
return_some hash
with Not_found -> fail (Invalid_protocol_argument arg))
(* Command-line only args (not in config file) *)
let base_dir_arg () =
arg
~long:"base-dir"
~short:'d'
~placeholder:"path"
~doc:
( "client data directory\n\
The directory where the Tezos client will store all its data.\n\
By default: '" ^ default_base_dir ^ "'." )
(string_parameter ())
let config_file_arg () =
arg
~long:"config-file"
~short:'c'
~placeholder:"path"
~doc:"configuration file"
(string_parameter ())
let timings_switch () =
switch ~long:"timings" ~short:'t' ~doc:"show RPC request times" ()
let chain_arg () =
default_arg
~long:"chain"
~placeholder:"hash|tag"
~doc:
"chain on which to apply contextual commands (possible tags are 'main' \
and 'test')"
~default:(Chain_services.to_string default_cli_args.chain)
(chain_parameter ())
let block_arg () =
default_arg
~long:"block"
~short:'b'
~placeholder:"hash|tag"
~doc:
"block on which to apply contextual commands (possible tags are 'head' \
and 'genesis')"
~default:(Block_services.to_string default_cli_args.block)
(block_parameter ())
let wait_arg () =
arg
~long:"wait"
~short:'w'
~placeholder:"none|<int>"
~doc:
"how many confirmation blocks before to consider an operation as included"
(wait_parameter ())
let protocol_arg () =
arg
~long:"protocol"
~short:'p'
~placeholder:"hash"
~doc:"use commands of a specific protocol"
(protocol_parameter ())
let log_requests_switch () =
switch ~long:"log-requests" ~short:'l' ~doc:"log all requests to the node" ()
(* Command-line args which can be set in config file as well *)
let addr_arg () =
arg
~long:"addr"
~short:'A'
~placeholder:"IP addr|host"
~doc:"IP address of the node"
(string_parameter ())
let port_arg () =
arg
~long:"port"
~short:'P'
~placeholder:"number"
~doc:"RPC port of the node"
(parameter (fun _ x ->
try return (int_of_string x)
with Failure _ -> fail (Invalid_port_arg x)))
let tls_switch () =
switch ~long:"tls" ~short:'S' ~doc:"use TLS to connect to node." ()
let remote_signer_arg () =
arg
~long:"remote-signer"
~short:'R'
~placeholder:"uri"
~doc:"URI of the remote signer"
(parameter (fun _ x -> Tezos_signer_backends_unix.Remote.parse_base_uri x))
let password_filename_arg () =
arg
~long:"password-filename"
~short:'f'
~placeholder:"filename"
~doc:"path to the password filename"
(string_parameter ())
let read_config_file config_file =
Lwt_utils_unix.Json.read_file config_file
>>=? fun cfg_json ->
try return @@ Cfg_file.from_json cfg_json
with exn ->
failwith
"Can't parse the configuration file: %s@,%a"
config_file
(fun ppf exn -> Json_encoding.print_error ppf exn)
exn
let default_config_file_name = "config"
let commands config_file cfg =
let open Clic in
let group =
{
Clic.name = "config";
title = "Commands for editing and viewing the client's config file";
}
in
[ command
~group
~desc:"Show the config file."
no_options
(fixed ["config"; "show"])
(fun () (cctxt : #Client_context.full) ->
let pp_cfg ppf cfg =
Format.fprintf
ppf
"%a"
Data_encoding.Json.pp
(Data_encoding.Json.construct Cfg_file.encoding cfg)
in
if not @@ Sys.file_exists config_file then
cctxt#warning
"@[<v 2>Warning: no config file at %s,@,\
displaying the default configuration.@]"
config_file
>>= fun () -> cctxt#warning "%a@," pp_cfg Cfg_file.default >>= return
else
read_config_file config_file
>>=? fun cfg -> cctxt#message "%a@," pp_cfg cfg >>= return);
command
~group
~desc:"Reset the config file to the factory defaults."
no_options
(fixed ["config"; "reset"])
(fun () _cctxt -> Cfg_file.(write config_file default));
command
~group
~desc:
"Update the config based on the current cli values.\n\
Loads the current configuration (default or as specified with \
`-config-file`), applies alterations from other command line \
arguments (such as the node's address, etc.), and overwrites the \
updated configuration file."
no_options
(fixed ["config"; "update"])
(fun () _cctxt -> Cfg_file.(write config_file cfg));
command
~group
~desc:
"Create a config file based on the current CLI values.\n\
If the `-file` option is not passed, this will initialize the \
default config file, based on default parameters, altered by other \
command line options (such as the node's address, etc.).\n\
Otherwise, it will create a new config file, based on the default \
parameters (or the the ones specified with `-config-file`), altered \
by other command line options.\n\
The command will always fail if the file already exists."
(args1
(default_arg
~long:"output"
~short:'o'
~placeholder:"path"
~doc:"path at which to create the file"
~default:(cfg.base_dir // default_config_file_name)
(parameter (fun _ctx str -> return str))))
(fixed ["config"; "init"])
(fun config_file _cctxt ->
if not (Sys.file_exists config_file) then
Cfg_file.(write config_file cfg)
(* Should be default or command would have failed *)
else failwith "Config file already exists at location") ]
let global_options () =
args13
(base_dir_arg ())
(config_file_arg ())
(timings_switch ())
(chain_arg ())
(block_arg ())
(wait_arg ())
(protocol_arg ())
(log_requests_switch ())
(addr_arg ())
(port_arg ())
(tls_switch ())
(remote_signer_arg ())
(password_filename_arg ())
type parsed_config_args = {
parsed_config_file : Cfg_file.t option;
parsed_args : cli_args option;
config_commands : Client_context.full command list;
base_dir : string option;
require_auth : bool;
password_filename : string option;
}
let default_parsed_config_args =
{
parsed_config_file = None;
parsed_args = None;
config_commands = [];
base_dir = None;
require_auth = false;
password_filename = None;
}
let parse_config_args (ctx : #Client_context.full) argv =
parse_global_options (global_options ()) ctx argv
>>=? fun ( ( base_dir,
config_file,
timings,
chain,
block,
confirmations,
protocol,
log_requests,
node_addr,
node_port,
tls,
remote_signer,
password_filename ),
remaining ) ->
( match base_dir with
| None ->
let base_dir = default_base_dir in
unless (Sys.file_exists base_dir) (fun () ->
Lwt_utils_unix.create_dir base_dir >>= return)
>>=? fun () -> return base_dir
| Some dir ->
if not (Sys.file_exists dir) then
failwith
"Specified -base-dir does not exist. Please create the directory \
and try again."
else if Sys.is_directory dir then return dir
else failwith "Specified -base-dir must be a directory" )
>>=? fun base_dir ->
( match config_file with
| None ->
return @@ (base_dir // default_config_file_name)
| Some config_file ->
if Sys.file_exists config_file then return config_file
else
failwith
"Config file specified in option does not exist. Use `client config \
init` to create one." )
>>=? fun config_file ->
let config_dir = Filename.dirname config_file in
let protocol = match protocol with None -> None | Some p -> p in
( if not (Sys.file_exists config_file) then
return {Cfg_file.default with base_dir}
else read_config_file config_file )
>>=? fun cfg ->
let tls = cfg.tls || tls in
let node_addr = Option.unopt ~default:cfg.node_addr node_addr in
let node_port = Option.unopt ~default:cfg.node_port node_port in
Tezos_signer_backends_unix.Remote.read_base_uri_from_env ()
>>=? fun remote_signer_env ->
let remote_signer =
Option.first_some
remote_signer
(Option.first_some remote_signer_env cfg.remote_signer)
in
let confirmations = Option.unopt ~default:cfg.confirmations confirmations in
let cfg =
{
cfg with
tls;
node_port;
node_addr;
remote_signer;
confirmations;
password_filename;
}
in
if Sys.file_exists base_dir && not (Sys.is_directory base_dir) then (
Format.eprintf "%s is not a directory.@." base_dir ;
exit 1 ) ;
if Sys.file_exists config_dir && not (Sys.is_directory config_dir) then (
Format.eprintf "%s is not a directory.@." config_dir ;
exit 1 ) ;
Lwt_utils_unix.create_dir config_dir
>>= fun () ->
return
( {
default_parsed_config_args with
parsed_config_file = Some cfg;
parsed_args =
Some
{
chain;
block;
confirmations;
print_timings = timings;
log_requests;
password_filename;
protocol;
};
config_commands = commands config_file cfg;
},
remaining )
type t =
string option
* string option
* bool
* Shell_services.chain
* Shell_services.block
* int option option
* Protocol_hash.t option option
* bool
* string option
* int option
* bool
* Uri.t option
* string option
module type Remote_params = sig
val authenticate :
Signature.public_key_hash list -> Bytes.t -> Signature.t tzresult Lwt.t
val logger : RPC_client_unix.logger
end
let other_registrations : (_ -> (module Remote_params) -> _) option =
Some
(fun parsed_config_file (module Remote_params) ->
Option.iter parsed_config_file.Cfg_file.remote_signer ~f:(fun signer ->
Client_keys.register_signer
( module Tezos_signer_backends_unix.Remote.Make
(RPC_client_unix)
(struct
let default = signer
include Remote_params
end) )))
let clic_commands ~base_dir:_ ~config_commands ~builtin_commands
~other_commands ~require_auth:_ =
config_commands @ builtin_commands @ other_commands
let logger = None
src/lib_client_base_unix/client_config.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition home : string :=
(* ❌ Try-with are not handled *)
try (Sys.getenv "HOME" % string).
Definition default_base_dir : string :=
Filename.concat home ".tezos-client" % string.
Definition default_chain : variant :=
(* ❌ Variants not supported *)
variant.
Definition default_block : variant :=
(* ❌ Variants not supported *)
variant.
Definition op_divdiv : string -> string -> string := Filename.concat.
Module Cfg_file.
Record t := {
base_dir : string;
node_addr : string;
node_port : Z;
tls : bool;
web_port : Z;
remote_signer : option Uri.t;
confirmations : option Z;
password_filename : option string }.
Definition default : t :=
{| base_dir := default_base_dir; node_addr := "localhost" % string;
node_port := 8732; tls := false; web_port := 8080; remote_signer := None;
confirmations := Some 0; password_filename := None |}.
Import Data_encoding.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
base_dir := base_dir;
node_addr := node_addr;
node_port := node_port;
tls := tls;
web_port := web_port;
remote_signer := remote_signer;
confirmations := confirmations;
password_filename := password_filename
|} := function_parameter in
(base_dir, (Some node_addr), (Some node_port), (Some tls),
(Some web_port), remote_signer, confirmations, password_filename))
(fun function_parameter =>
let
'(base_dir, node_addr, node_port, tls, web_port, remote_signer,
confirmations, password_filename) := function_parameter in
let node_addr := Option.unopt (node_addr default) node_addr in
let node_port := Option.unopt (node_port default) node_port in
let tls := Option.unopt (tls default) tls in
let web_port := Option.unopt (web_port default) web_port in
{| base_dir := base_dir; node_addr := node_addr; node_port := node_port;
tls := tls; web_port := web_port; remote_signer := remote_signer;
confirmations := confirmations; password_filename := password_filename
|}) None
(obj8 (req None None "base_dir" % string string)
(opt None None "node_addr" % string string)
(opt None None "node_port" % string int16)
(opt None None "tls" % string bool)
(opt None None "web_port" % string int16)
(opt None None "remote_signer" % string RPC_encoding.uri_encoding)
(opt None None "confirmations" % string int8)
(opt None None "password_filename" % string string)).
Definition from_json (json : Tezos_base__TzPervasives.Data_encoding.Json.json)
: t := Data_encoding.Json.destruct encoding json.
Definition read (fp : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
op_gtgteqquestion (Lwt_utils_unix.Json.read_file fp)
(fun json => _return (from_json json)).
Definition write (out : string) (cfg : t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
Lwt_utils_unix.Json.write_file out
(Data_encoding.Json.construct encoding cfg).
End Cfg_file.
Record cli_args := {
chain : Tezos_shell_services.Chain_services.chain;
block : Tezos_shell_services.Shell_services.block;
confirmations : option Z;
password_filename : option string;
protocol : option Tezos_base__TzPervasives.Protocol_hash.t;
print_timings : bool;
log_requests : bool }.
Definition default_cli_args : cli_args :=
{| chain := default_chain; block := default_block; confirmations := Some 0;
password_filename := None; protocol := None; print_timings := false;
log_requests := false |}.
Import Clic.
Definition string_parameter {F G I a b i o p q : Type}
(function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter string
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => _return x).
Definition chain_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter
Tezos_shell_services.Chain_services.chain A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun chain =>
match Chain_services.parse_chain chain with
| Stdlib.Error _ =>
fail (Tezos_base__TzPervasives.Invalid_chain_argument chain)
| Stdlib.Ok chain => _return chain
end).
Definition block_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter
Tezos_shell_services.Block_services.block A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun block =>
match Block_services.parse_block block with
| Stdlib.Error _ =>
fail (Tezos_base__TzPervasives.Invalid_block_argument block)
| Stdlib.Ok block => _return block
end).
Definition wait_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter (option Z) A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun wait =>
match wait with
| "no" % string | "none" % string => return_none
| _ =>
(* ❌ Try-with are not handled *)
try
(let w := OCaml.Stdlib.int_of_string wait in
if OCaml.Stdlib.le 0 w then
return_some w
else
fail (Tezos_base__TzPervasives.Invalid_wait_arg wait))
end).
Definition protocol_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter
(option Tezos_base__TzPervasives.Protocol_hash.t) A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun arg =>
(* ❌ Try-with are not handled *)
try
(let '(hash, _commands) :=
List.find
(fun function_parameter =>
let '(hash, _commands) := function_parameter in
String.has_prefix arg (Protocol_hash.to_b58check hash))
(Client_commands.get_versions tt) in
return_some hash)).
Definition base_dir_arg {F G I a b i o p q : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string)
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
arg
(String.append
"client data directory
The directory where the Tezos client will store all its data.
By default: '"
% string (String.append default_base_dir "'." % string))
(Some "d" % char) "base-dir" % string "path" % string (string_parameter tt).
Definition config_file_arg {F G I a b i o p q : Type}
(function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string)
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
arg "configuration file" % string (Some "c" % char) "config-file" % string
"path" % string (string_parameter tt).
Definition timings_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
switch "show RPC request times" % string (Some "t" % char) "timings" % string
tt.
Definition chain_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg Tezos_shell_services.Chain_services.chain
A :=
let 'tt := function_parameter in
default_arg
"chain on which to apply contextual commands (possible tags are 'main' and 'test')"
% string None "chain" % string "hash|tag" % string
(Chain_services.to_string (chain default_cli_args)) (chain_parameter tt).
Definition block_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg Tezos_shell_services.Block_services.block
A :=
let 'tt := function_parameter in
default_arg
"block on which to apply contextual commands (possible tags are 'head' and 'genesis')"
% string (Some "b" % char) "block" % string "hash|tag" % string
(Block_services.to_string (block default_cli_args)) (block_parameter tt).
Definition wait_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option (option Z)) A :=
let 'tt := function_parameter in
arg
"how many confirmation blocks before to consider an operation as included" %
string (Some "w" % char) "wait" % string "none|<int>" % string
(wait_parameter tt).
Definition protocol_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg
(option (option Tezos_base__TzPervasives.Protocol_hash.t)) A :=
let 'tt := function_parameter in
arg "use commands of a specific protocol" % string (Some "p" % char)
"protocol" % string "hash" % string (protocol_parameter tt).
Definition log_requests_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
switch "log all requests to the node" % string (Some "l" % char)
"log-requests" % string tt.
Definition addr_arg {F G I a b i o p q : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string)
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
arg "IP address of the node" % string (Some "A" % char) "addr" % string
"IP addr|host" % string (string_parameter tt).
Definition port_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option Z) A :=
let 'tt := function_parameter in
arg "RPC port of the node" % string (Some "P" % char) "port" % string
"number" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
(* ❌ Try-with are not handled *)
try (_return (OCaml.Stdlib.int_of_string x)))).
Definition tls_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
switch "use TLS to connect to node." % string (Some "S" % char) "tls" % string
tt.
Definition remote_signer_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option Uri.t) A :=
let 'tt := function_parameter in
arg "URI of the remote signer" % string (Some "R" % char)
"remote-signer" % string "uri" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => Tezos_signer_backends_unix.Remote.parse_base_uri x)).
Definition password_filename_arg {F G I a b i o p q : Type}
(function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string)
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
arg "path to the password filename" % string (Some "f" % char)
"password-filename" % string "filename" % string (string_parameter tt).
Definition read_config_file (config_file : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult Cfg_file.t) :=
op_gtgteqquestion (Lwt_utils_unix.Json.read_file config_file)
(fun cfg_json =>
(* ❌ Try-with are not handled *)
try (apply _return (Cfg_file.from_json cfg_json))).
Definition default_config_file_name : string := "config" % string.
Definition commands {F G I a b i o p q : Type}
(config_file : string) (cfg : Cfg_file.t)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let group :=
{| Clic.name := "config" % string;
Clic.title :=
"Commands for editing and viewing the client's config file" % string |}
in
cons
(command (Some group) "Show the config file." % string no_options
(fixed (cons "config" % string (cons "show" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
let pp_cfg (ppf : Stdlib.Format.formatter) (cfg : Cfg_file.t)
: unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Data_encoding.Json.pp
(Data_encoding.Json.construct Cfg_file.encoding cfg) in
if apply negb (Sys.file_exists config_file) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Warning: no config file at " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"displaying the default configuration." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>Warning: no config file at %s,@,displaying the default configuration.@]"
% string) config_file)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format))
"%a@," % string) pp_cfg Cfg_file.default) _return)
else
op_gtgteqquestion (read_config_file config_file)
(fun cfg =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format))
"%a@," % string) pp_cfg cfg) _return)))
(cons
(command (Some group)
"Reset the config file to the factory defaults." % string no_options
(fixed (cons "config" % string (cons "reset" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun _cctxt => write config_file default))
(cons
(command (Some group)
"Update the config based on the current cli values.
Loads the current configuration (default or as specified with `-config-file`), applies alterations from other command line arguments (such as the node's address, etc.), and overwrites the updated configuration file."
% string no_options
(fixed (cons "config" % string (cons "update" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun _cctxt => write config_file cfg))
(cons
(command (Some group)
"Create a config file based on the current CLI values.
If the `-file` option is not passed, this will initialize the default config file, based on default parameters, altered by other command line options (such as the node's address, etc.).
Otherwise, it will create a new config file, based on the default parameters (or the the ones specified with `-config-file`), altered by other command line options.
The command will always fail if the file already exists."
% string
(args1
(default_arg "path at which to create the file" % string
(Some "o" % char) "output" % string "path" % string
(op_divdiv (base_dir cfg) default_config_file_name)
(parameter None (fun _ctx => fun str => _return str))))
(fixed (cons "config" % string (cons "init" % string [])))
(fun config_file =>
fun _cctxt =>
if negb (Sys.file_exists config_file) then
write config_file cfg
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Config file already exists at location" % string
CamlinternalFormatBasics.End_of_format)
"Config file already exists at location" % string))) []))).
Definition global_options {F G I a b i o p q : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.options
((option string) * (option string) * bool *
Tezos_shell_services.Chain_services.chain *
Tezos_shell_services.Block_services.block * (option (option Z)) *
(option (option Tezos_base__TzPervasives.Protocol_hash.t)) * bool *
(option string) * (option Z) * bool * (option Uri.t) * (option string))
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
args13 (base_dir_arg tt) (config_file_arg tt) (timings_switch tt)
(chain_arg tt) (block_arg tt) (wait_arg tt) (protocol_arg tt)
(log_requests_switch tt) (addr_arg tt) (port_arg tt) (tls_switch tt)
(remote_signer_arg tt) (password_filename_arg tt).
Record parsed_config_args := {
parsed_config_file : option Cfg_file.t;
parsed_args : option cli_args;
config_commands :
list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full);
base_dir : option string;
require_auth : bool;
password_filename : option string }.
Definition default_parsed_config_args : parsed_config_args :=
{| parsed_config_file := None; parsed_args := None; config_commands := [];
base_dir := None; require_auth := false; password_filename := None |}.
Definition parse_config_args {F G I a b i o p q : Type}
(ctx :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (argv : list string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult (parsed_config_args * (list string))) :=
op_gtgteqquestion (parse_global_options (global_options tt) ctx argv)
(fun function_parameter =>
let
'((base_dir, config_file, timings, chain, block, confirmations,
protocol, log_requests, node_addr, node_port, tls, remote_signer,
password_filename), remaining) := function_parameter in
op_gtgteqquestion
match base_dir with
| None =>
let base_dir := default_base_dir in
op_gtgteqquestion
(unless (Sys.file_exists base_dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_utils_unix.create_dir None base_dir) _return))
(fun function_parameter =>
let 'tt := function_parameter in
_return base_dir)
| Some dir =>
if negb (Sys.file_exists dir) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Specified -base-dir does not exist. Please create the directory and try again."
% string CamlinternalFormatBasics.End_of_format)
"Specified -base-dir does not exist. Please create the directory and try again."
% string)
else
if Sys.is_directory dir then
_return dir
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Specified -base-dir must be a directory" % string
CamlinternalFormatBasics.End_of_format)
"Specified -base-dir must be a directory" % string)
end
(fun base_dir =>
op_gtgteqquestion
match config_file with
| None =>
apply _return (op_divdiv base_dir default_config_file_name)
| Some config_file =>
if Sys.file_exists config_file then
_return config_file
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Config file specified in option does not exist. Use `client config init` to create one."
% string CamlinternalFormatBasics.End_of_format)
"Config file specified in option does not exist. Use `client config init` to create one."
% string)
end
(fun config_file =>
let config_dir := Filename.dirname config_file in
let protocol :=
match protocol with
| None => None
| Some p => p
end in
op_gtgteqquestion
(if negb (Sys.file_exists config_file) then
_return
(* ❌ Record substitution not handled *)
record_substitution
else
read_config_file config_file)
(fun cfg =>
let tls := orb (tls cfg) tls in
let node_addr := Option.unopt (node_addr cfg) node_addr in
let node_port := Option.unopt (node_port cfg) node_port in
op_gtgteqquestion
(Tezos_signer_backends_unix.Remote.read_base_uri_from_env tt)
(fun remote_signer_env =>
let remote_signer :=
Option.first_some remote_signer
(Option.first_some remote_signer_env
(remote_signer cfg)) in
let confirmations :=
Option.unopt (confirmations cfg) confirmations in
let cfg :=
(* ❌ Record substitution not handled *)
record_substitution in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
andb (Sys.file_exists base_dir)
(negb (Sys.is_directory base_dir)) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is not a directory." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
"%s is not a directory.@." % string) base_dir in
Stdlib.exit 1
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
andb (Sys.file_exists config_dir)
(negb (Sys.is_directory config_dir)) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is not a directory." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
"%s is not a directory.@." % string) config_dir
in
Stdlib.exit 1
else
tt in
op_gtgteq (Lwt_utils_unix.create_dir None config_dir)
(fun function_parameter =>
let 'tt := function_parameter in
_return
((* ❌ Record substitution not handled *)
record_substitution, remaining))))))).
Definition t :=
(option string) * (option string) * bool *
Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block * (option (option Z)) *
(option (option Tezos_base__TzPervasives.Protocol_hash.t)) * bool *
(option string) * (option Z) * bool * (option Uri.t) * (option string).
Module Remote_params.
Record signature := {
authenticate : (list Tezos_base__TzPervasives.Signature.public_key_hash) ->
Stdlib.Bytes.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.t);
logger : Tezos_rpc_http_client_unix.RPC_client_unix.logger;
}.
End Remote_params.
Definition other_registrations
: option (Cfg_file.t -> {_ : unit & Remote_params.signature } -> unit) :=
Some
(fun parsed_config_file =>
fun Remote_params =>
let Remote_params := projT2 Remote_params in
Option.iter
(fun signer =>
Client_keys.register_signer
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application)
(Cfg_file.remote_signer parsed_config_file)).
Definition clic_commands {A B C : Type} (function_parameter : A)
: (list B) -> (list B) -> (list B) -> C -> list B :=
let '_ := function_parameter in
fun config_commands =>
fun builtin_commands =>
fun other_commands =>
fun function_parameter =>
let '_ := function_parameter in
OCaml.Stdlib.app config_commands
(OCaml.Stdlib.app builtin_commands other_commands).
Definition logger {A : Type} : option A := None.
src/lib_client_base_unix/client_context_unix.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "client.context.unix"
end)
class unix_wallet ~base_dir ~password_filename : Client_context.wallet =
object (self)
method load_passwords =
match password_filename with
| None ->
None
| Some filename ->
if Sys.file_exists filename then Some (Lwt_io.lines_of_file filename)
else None
method read_file path =
Lwt.catch
(fun () ->
Lwt_io.(with_file ~mode:Input path read)
>>= fun content -> return content)
(fun exn -> failwith "cannot read file (%s)" (Printexc.to_string exn))
method private filename alias_name =
Filename.concat
base_dir
(String.map (function ' ' -> '_' | c -> c) alias_name ^ "s")
method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t =
fun f ->
let unlock fd =
let fd = Lwt_unix.unix_file_descr fd in
Unix.lockf fd Unix.F_ULOCK 0 ;
Unix.close fd
in
let lock () =
Lwt_unix.openfile
(Filename.concat base_dir "wallet_lock")
Lwt_unix.[O_CREAT; O_WRONLY]
0o644
>>= fun fd ->
Lwt_unix.lockf fd Unix.F_LOCK 0
>>= fun () ->
let sighandler =
Lwt_unix.on_signal Sys.sigint (fun _s -> unlock fd)
in
Lwt.return (fd, sighandler)
in
lock ()
>>= fun (fd, sh) ->
(* catch might be useless if f always uses the error monad *)
Lwt.catch f (function e -> Lwt.return (unlock fd ; raise e))
>>= fun res ->
Lwt.return (unlock fd)
>>= fun () ->
Lwt_unix.disable_signal_handler sh ;
Lwt.return res
method load : type a.
string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
fun alias_name ~default encoding ->
let filename = self#filename alias_name in
if not (Sys.file_exists filename) then return default
else
Lwt_utils_unix.Json.read_file filename
|> generic_trace "could not read the %s alias file" alias_name
>>=? fun json ->
match Data_encoding.Json.destruct encoding json with
| exception e ->
failwith
"did not understand the %s alias file %s : %s"
alias_name
filename
(Printexc.to_string e)
| data ->
return data
method write : type a.
string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
fun alias_name list encoding ->
Lwt.catch
(fun () ->
Lwt_utils_unix.create_dir base_dir
>>= fun () ->
let filename = self#filename alias_name in
let json = Data_encoding.Json.construct encoding list in
Lwt_utils_unix.Json.write_file filename json)
(fun exn -> Lwt.return (error_exn exn))
|> generic_trace "could not write the %s alias file." alias_name
end
class unix_prompter : Client_context.prompter =
object
method prompt : type a. (a, string tzresult) Client_context.lwt_format -> a
=
Format.kasprintf (fun msg ->
print_string msg ;
let line = read_line () in
return line)
method prompt_password : type a.
(a, Bigstring.t tzresult) Client_context.lwt_format -> a =
Format.kasprintf (fun msg ->
print_string msg ;
let line = Lwt_utils_unix.getpass () in
return (Bigstring.of_string line))
end
class unix_logger ~base_dir : Client_context.printer =
let startup = Format.asprintf "%a" Time.System.pp_hum (Systime_os.now ()) in
let log channel msg =
match channel with
| "stdout" ->
print_endline msg ; Lwt.return_unit
| "stderr" ->
prerr_endline msg ; Lwt.return_unit
| log ->
let ( // ) = Filename.concat in
Lwt_utils_unix.create_dir (base_dir // "logs" // log)
>>= fun () ->
Lwt_io.with_file
~flags:Unix.[O_APPEND; O_CREAT; O_WRONLY]
~mode:Lwt_io.Output
(base_dir // "logs" // log // startup)
(fun chan -> Lwt_io.write chan msg)
in
object
inherit Client_context.simple_printer log
end
class unix_ui : Client_context.ui =
object
method sleep f = Lwt_unix.sleep f
method now = Tezos_stdlib_unix.Systime_os.now
end
class unix_full ~base_dir ~chain ~block ~confirmations ~password_filename
~rpc_config : Client_context.full =
object
inherit unix_logger ~base_dir
inherit unix_prompter
inherit unix_wallet ~base_dir ~password_filename
inherit RPC_client_unix.http_ctxt rpc_config Media_type.all_media_types
inherit unix_ui
method chain = chain
method block = block
method confirmations = confirmations
end
src/lib_client_base_unix/client_context_unix.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `class` not handled. *) class (* ❌ Structure item `class` not handled. *) class (* ❌ Structure item `class` not handled. *) class (* ❌ Structure item `class` not handled. *) class (* ❌ Structure item `class` not handled. *) class
src/lib_client_base_unix/client_main_run.ml 114 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Command line interface - Main Program *)
open Client_context_unix
let builtin_commands =
let open Clic in
[ command
~desc:"List the protocol versions that this client understands."
no_options
(fixed ["list"; "understood"; "protocols"])
(fun () (cctxt : #Client_context.full) ->
Lwt_list.iter_s
(fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver)
(Client_commands.get_versions ())
>>= fun () -> return_unit) ]
module type M = sig
type t
val global_options : unit -> (t, Client_context_unix.unix_full) Clic.options
val parse_config_args :
#Tezos_client_base.Client_context.full ->
string list ->
(Client_config.parsed_config_args * string list) tzresult Lwt.t
val default_chain : Chain_services.chain
val default_block : [> `Head of int]
val default_base_dir : string
val other_registrations :
(Client_config.Cfg_file.t -> (module Client_config.Remote_params) -> unit)
option
val clic_commands :
base_dir:string ->
config_commands:Tezos_client_base.Client_context.full Clic.command list ->
builtin_commands:Tezos_client_base.Client_context.full Clic.command list ->
other_commands:Tezos_client_base.Client_context.full Clic.command list ->
require_auth:bool ->
Tezos_client_base.Client_context.full Clic.command list
val logger : RPC_client_unix.logger option
end
(* Main (lwt) entry *)
let main (module C : M) ~select_commands =
let global_options = C.global_options () in
let executable_name = Filename.basename Sys.executable_name in
let (original_args, autocomplete) =
(* for shell aliases *)
let rec move_autocomplete_token_upfront acc = function
| "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args ->
let args = List.rev acc @ args in
(args, Some (prev_arg, cur_arg, script))
| x :: rest ->
move_autocomplete_token_upfront (x :: acc) rest
| [] ->
(List.rev acc, None)
in
match Array.to_list Sys.argv with
| _ :: args ->
move_autocomplete_token_upfront [] args
| [] ->
([], None)
in
Random.self_init () ;
ignore
Clic.(
setup_formatter
Format.std_formatter
(if Unix.isatty Unix.stdout then Ansi else Plain)
Short) ;
ignore
Clic.(
setup_formatter
Format.err_formatter
(if Unix.isatty Unix.stderr then Ansi else Plain)
Short) ;
Internal_event_unix.init ()
>>= fun () ->
Lwt.catch
(fun () ->
C.parse_config_args
(new unix_full
~chain:C.default_chain
~block:C.default_block
~confirmations:None
~password_filename:None
~base_dir:C.default_base_dir
~rpc_config:RPC_client_unix.default_config)
original_args
>>=? (fun (parsed, remaining) ->
let parsed_config_file = parsed.Client_config.parsed_config_file
and parsed_args = parsed.Client_config.parsed_args
and config_commands = parsed.Client_config.config_commands in
let base_dir : string =
match parsed.Client_config.base_dir with
| Some p ->
p
| None -> (
match parsed_config_file with
| None ->
C.default_base_dir
| Some p ->
p.Client_config.Cfg_file.base_dir )
and require_auth = parsed.Client_config.require_auth in
let rpc_config =
let rpc_config : RPC_client_unix.config =
match parsed_config_file with
| None ->
RPC_client_unix.default_config
| Some parsed_config_file ->
{
RPC_client_unix.default_config with
host =
parsed_config_file.Client_config.Cfg_file.node_addr;
port =
parsed_config_file.Client_config.Cfg_file.node_port;
tls = parsed_config_file.Client_config.Cfg_file.tls;
}
in
match parsed_args with
| Some parsed_args ->
if parsed_args.Client_config.print_timings then
let gettimeofday = Unix.gettimeofday in
{
rpc_config with
logger =
RPC_client_unix.timings_logger
~gettimeofday
Format.err_formatter;
}
else if parsed_args.Client_config.log_requests then
{
rpc_config with
logger =
RPC_client_unix.full_logger Format.err_formatter;
}
else rpc_config
| None ->
rpc_config
in
let client_config =
new unix_full
~chain:
( match parsed_args with
| Some p ->
p.Client_config.chain
| None ->
Client_config.default_chain )
~block:
( match parsed_args with
| Some p ->
p.Client_config.block
| None ->
Client_config.default_block )
~confirmations:
( match parsed_args with
| Some p ->
p.Client_config.confirmations
| None ->
None )
~password_filename:
( match parsed_args with
| Some p ->
p.Client_config.password_filename
| None ->
None )
~base_dir
~rpc_config
in
let module Remote_params = struct
let authenticate pkhs payload =
Client_keys.list_keys client_config
>>=? fun keys ->
match
List.filter_map
(function
| (_, known_pkh, _, Some known_sk_uri)
when List.exists
(fun pkh ->
Signature.Public_key_hash.equal pkh known_pkh)
pkhs ->
Some known_sk_uri
| _ ->
None)
keys
with
| sk_uri :: _ ->
Client_keys.sign client_config sk_uri payload
| [] ->
failwith
"remote signer expects authentication signature, but \
no authorized key was found in the wallet"
let logger =
(* overriding the logger we might already have with the one from
module C *)
match C.logger with
| Some logger ->
logger
| None ->
rpc_config.logger
end in
let module Http =
Tezos_signer_backends.Http.Make
(RPC_client_unix)
(Remote_params)
in
let module Https =
Tezos_signer_backends.Https.Make
(RPC_client_unix)
(Remote_params)
in
let module Socket =
Tezos_signer_backends_unix.Socket.Make (Remote_params) in
Client_keys.register_signer
( module Tezos_signer_backends.Encrypted.Make (struct
let cctxt = (client_config :> Client_context.prompter)
end) ) ;
Client_keys.register_signer
(module Tezos_signer_backends.Unencrypted) ;
Client_keys.register_signer
(module Tezos_signer_backends_unix.Ledger.Signer_implementation) ;
Client_keys.register_signer (module Socket.Unix) ;
Client_keys.register_signer (module Socket.Tcp) ;
Client_keys.register_signer (module Http) ;
Client_keys.register_signer (module Https) ;
( match parsed_config_file with
| None ->
()
| Some parsed_config_file -> (
match C.other_registrations with
| Some r ->
r parsed_config_file (module Remote_params)
| None ->
() ) ) ;
( match parsed_args with
| Some parsed_args ->
select_commands
(client_config :> RPC_client_unix.http_ctxt)
parsed_args
| None ->
return_nil )
>>=? fun other_commands ->
let commands =
Clic.add_manual
~executable_name
~global_options
(if Unix.isatty Unix.stdout then Clic.Ansi else Clic.Plain)
Format.std_formatter
(C.clic_commands
~base_dir
~config_commands
~builtin_commands
~other_commands
~require_auth)
in
match autocomplete with
| Some (prev_arg, cur_arg, script) ->
Clic.autocompletion
~script
~cur_arg
~prev_arg
~args:original_args
~global_options
commands
client_config
>>=? fun completions ->
List.iter print_endline completions ;
return_unit
| None ->
Clic.dispatch commands client_config remaining)
>>= function
| Ok () ->
Lwt.return 0
| Error [Clic.Help command] ->
Clic.usage
Format.std_formatter
~executable_name
~global_options
(match command with None -> [] | Some c -> [c]) ;
Lwt.return 0
| Error errs ->
Clic.pp_cli_errors
Format.err_formatter
~executable_name
~global_options
~default:Error_monad.pp
errs ;
Lwt.return 1)
(function
| Client_commands.Version_not_found ->
Format.eprintf
"@{<error>@{<title>Fatal error@}@} unknown protocol version.@." ;
Lwt.return 1
| Failure message ->
Format.eprintf
"@{<error>@{<title>Fatal error@}@}@. @[<h 0>%a@]@."
Format.pp_print_text
message ;
Lwt.return 1
| exn ->
Format.printf
"@{<error>@{<title>Fatal error@}@}@. @[<h 0>%a@]@."
Format.pp_print_text
(Printexc.to_string exn) ;
Lwt.return 1)
>>= fun retcode ->
Format.pp_print_flush Format.err_formatter () ;
Format.pp_print_flush Format.std_formatter () ;
Internal_event_unix.close () >>= fun () -> Lwt.return retcode
(* Where all the user friendliness starts *)
let run ?log (module M : M)
~(select_commands :
RPC_client_unix.http_ctxt ->
Client_config.cli_args ->
Client_context.full Clic.command list tzresult Lwt.t) =
Lwt_exit.exit_on ?log Sys.sigint ;
Lwt_exit.exit_on ?log Sys.sigterm ;
Pervasives.exit @@ Lwt_main.run @@ Lwt_exit.wrap_promise
@@ main (module M) ~select_commands
src/lib_client_base_unix/client_main_run.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_context_unix.
Definition builtin_commands {F G a b i o p q : Type}
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * nil)))))))))))))))))))))
* nil)) :=
cons
(command None
"List the protocol versions that this client understands." % string
no_options
(fixed
(cons "list" % string
(cons "understood" % string (cons "protocols" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(ver, _) := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Protocol_hash.pp_short ver) (Client_commands.get_versions tt))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) [].
Module M.
Record signature {t : Type} := {
t := t;
global_options : unit ->
Tezos_base__TzPervasives.Clic.options t
Tezos_client_base_unix.Client_context_unix.unix_full;
parse_config_args : forall {_ a b i o p q variant : Type}, (((Z ->
Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (_ * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (_ * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * _)))))))))))))))))))))
* _) ->
(list string) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_base_unix.Client_config.parsed_config_args *
(list string)));
default_chain : Tezos_shell_services.Chain_services.chain;
default_block : forall {variant : Type}, variant;
default_base_dir : string;
other_registrations : option
(Tezos_client_base_unix.Client_config.Cfg_file.t ->
{_ : unit &
Tezos_client_base_unix.Client_config.Remote_params.signature } -> unit);
clic_commands : string ->
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)) ->
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)) ->
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)) ->
bool ->
list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full);
logger : option Tezos_rpc_http_client_unix.RPC_client_unix.logger;
}.
Arguments signature : clear implicits.
End M.
Definition main (C : {t : _ & M.signature t})
: (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
Tezos_client_base_unix.Client_config.cli_args ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)))) -> Lwt.t Z :=
let C := projT2 C in
fun select_commands =>
let global_options := C.(M.global_options) tt in
let executable_name := Filename.basename Sys.executable_name in
let '(original_args, autocomplete) :=
let fix move_autocomplete_token_upfront
(acc : list string) (function_parameter : list string)
: (list string) * (option (string * string * string)) :=
match function_parameter with
|
cons "bash_autocomplete" % string
(cons prev_arg (cons cur_arg (cons script args))) =>
let args := OCaml.Stdlib.app (List.rev acc) args in
(args, (Some (prev_arg, cur_arg, script)))
| cons x rest => move_autocomplete_token_upfront (cons x acc) rest
| [] => ((List.rev acc), None)
end in
match Array.to_list Sys.argv with
| cons _ args => move_autocomplete_token_upfront [] args
| [] => ([], None)
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Random.self_init tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter Format.std_formatter
(if Unix.isatty Unix.stdout then
Tezos_base__TzPervasives.Clic.Ansi
else
Tezos_base__TzPervasives.Clic.Plain)
Tezos_base__TzPervasives.Clic.Short) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter Format.err_formatter
(if Unix.isatty Unix.stderr then
Tezos_base__TzPervasives.Clic.Ansi
else
Tezos_base__TzPervasives.Clic.Plain)
Tezos_base__TzPervasives.Clic.Short) in
op_gtgteq (Internal_event_unix.init None None tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtgteqquestion
(C.(M.parse_config_args)
((* ❌ Creation of new objects is not handled *)
new C.(M.default_base_dir) C.(M.default_chain)
C.(M.default_block) None None
RPC_client_unix.default_config) original_args)
(fun function_parameter =>
let '(parsed, remaining) := function_parameter in
let parsed_config_file
: option Tezos_client_base_unix.Client_config.Cfg_file.t :=
Client_config.parsed_config_file parsed
with parsed_args
: option Tezos_client_base_unix.Client_config.cli_args :=
Client_config.parsed_args parsed
with config_commands
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full) :=
Client_config.config_commands parsed in
let base_dir : string :=
match Client_config.base_dir parsed with
| Some p => p
| None =>
match parsed_config_file with
| None => C.(M.default_base_dir)
| Some p => Client_config.Cfg_file.base_dir p
end
end
with require_auth : bool :=
Client_config.require_auth parsed in
let rpc_config :=
let rpc_config :=
match parsed_config_file with
| None => RPC_client_unix.default_config
| Some parsed_config_file =>
(* ❌ Record substitution not handled *)
record_substitution
end in
match parsed_args with
| Some parsed_args =>
if Client_config.print_timings parsed_args then
let gettimeofday := Unix.gettimeofday in
(* ❌ Record substitution not handled *)
record_substitution
else
if Client_config.log_requests parsed_args then
(* ❌ Record substitution not handled *)
record_substitution
else
rpc_config
| None => rpc_config
end in
let client_config :=
(* ❌ Creation of new objects is not handled *)
new base_dir
match parsed_args with
| Some p => Client_config.chain p
| None => Client_config.default_chain
end
match parsed_args with
| Some p => Client_config.block p
| None => Client_config.default_block
end
match parsed_args with
| Some p => Client_config.confirmations p
| None => None
end
match parsed_args with
| Some p => Client_config.password_filename p
| None => None
end rpc_config in
let Remote_params :=
existT _ unit
{|
(* ❌ This kind of definition of value for first-class modules is not handled *)
Tezos_client_base_unix__Client_config.Remote_params.authenticate :=
unhandled;
Tezos_client_base_unix__Client_config.Remote_params.logger :=
match C.(M.logger) with
| Some logger => logger
| None => logger rpc_config
end
|} in
let Http :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let Https :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let Socket :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Client_keys.register_signer
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Client_keys.register_signer
Tezos_signer_backends.Unencrypted in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Client_keys.register_signer
Tezos_signer_backends_unix.Ledger.Signer_implementation
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Client_keys.register_signer Socket.Unix in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Client_keys.register_signer Socket.Tcp in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Client_keys.register_signer Http in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Client_keys.register_signer Https in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match parsed_config_file with
| None => tt
| Some parsed_config_file =>
match C.(M.other_registrations) with
| Some r => r parsed_config_file Remote_params
| None => tt
end
end in
op_gtgteqquestion
match parsed_args with
| Some parsed_args =>
select_commands client_config parsed_args
| None => return_nil
end
(fun other_commands =>
let commands :=
Clic.add_manual executable_name global_options
(if Unix.isatty Unix.stdout then
Tezos_base__TzPervasives.Clic.Ansi
else
Tezos_base__TzPervasives.Clic.Plain)
Format.std_formatter
(C.(M.clic_commands) base_dir config_commands
builtin_commands other_commands require_auth) in
match autocomplete with
| Some (prev_arg, cur_arg, script) =>
op_gtgteqquestion
(Clic.autocompletion script cur_arg prev_arg
original_args global_options commands
client_config)
(fun completions =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter OCaml.Stdlib.print_endline completions
in
return_unit)
| None => Clic.dispatch commands client_config remaining
end)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt._return 0
|
Stdlib.Error
(cons (Tezos_error_monad.Error_monad.Help command) []) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Clic.usage Format.std_formatter executable_name
global_options
match command with
| None => []
| Some c => cons c []
end in
Lwt._return 0
| Stdlib.Error errs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Clic.pp_cli_errors Format.err_formatter executable_name
global_options Error_monad.pp errs in
Lwt._return 1
end))
(fun function_parameter =>
match function_parameter with
| Version_not_found =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<error>" % string
CamlinternalFormatBasics.End_of_format)
"<error>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Fatal error" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" unknown protocol version." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))
"@{<error>@{<title>Fatal error@}@} unknown protocol version.@."
% string) in
Lwt._return 1
| OCaml.Failure message =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<error>" % string
CamlinternalFormatBasics.End_of_format)
"<error>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Fatal error" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<h 0>" % string
CamlinternalFormatBasics.End_of_format)
"<h 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))
"@{<error>@{<title>Fatal error@}@}@. @[<h 0>%a@]@." %
string) Format.pp_print_text message in
Lwt._return 1
| exn =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<error>" % string
CamlinternalFormatBasics.End_of_format)
"<error>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Fatal error" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<h 0>" % string
CamlinternalFormatBasics.End_of_format)
"<h 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))
"@{<error>@{<title>Fatal error@}@}@. @[<h 0>%a@]@." %
string) Format.pp_print_text (Printexc.to_string exn) in
Lwt._return 1
end))
(fun retcode =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_flush Format.err_formatter tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_flush Format.std_formatter tt in
op_gtgteq (Internal_event_unix.close tt)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return retcode))).
Definition run {A : Type}
(log : option (string -> unit)) (M : {t : _ & M.signature t})
: (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
Tezos_client_base_unix.Client_config.cli_args ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)))) -> A :=
let M := projT2 M in
fun select_commands =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_exit.exit_on log Sys.sigint in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_exit.exit_on log Sys.sigterm in
apply Pervasives.exit
(apply Lwt_main.run (apply Lwt_exit.wrap_promise (main M select_commands))).
src/lib_client_commands/client_admin_commands.ml 40 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let block_param ~name ~desc t =
Clic.param
~name
~desc
(Clic.parameter (fun _ str -> Lwt.return (Block_hash.of_b58check str)))
t
let commands () =
let open Clic in
let group =
{
name = "admin";
title = "Commands to perform privileged operations on the node";
}
in
[ command
~group
~desc:"Make the node forget its decision of rejecting blocks."
no_options
( prefixes ["unmark"; "invalid"]
@@ seq_of_param
(block_param
~name:"block"
~desc:"blocks to remove from invalid list") )
(fun () blocks (cctxt : #Client_context.full) ->
iter_s
(fun block ->
Shell_services.Invalid_blocks.delete cctxt block
>>=? fun () ->
cctxt#message
"Block %a no longer marked invalid."
Block_hash.pp
block
>>= fun () -> return_unit)
blocks);
command
~group
~desc:"Make the node forget every decision of rejecting blocks."
no_options
(prefixes ["unmark"; "all"; "invalid"; "blocks"] @@ stop)
(fun () (cctxt : #Client_context.full) ->
Shell_services.Invalid_blocks.list cctxt ()
>>=? fun invalid_blocks ->
iter_s
(fun {Chain_services.hash; _} ->
Shell_services.Invalid_blocks.delete cctxt hash
>>=? fun () ->
cctxt#message
"Block %a no longer marked invalid."
Block_hash.pp_short
hash
>>= fun () -> return_unit)
invalid_blocks);
command
~group
~desc:
"Retrieve the current checkpoint and display it in a format \
compatible with node argument `--checkpoint`."
no_options
(fixed ["show"; "current"; "checkpoint"])
(fun () (cctxt : #Client_context.full) ->
Shell_services.Chain.checkpoint cctxt ~chain:cctxt#chain ()
>>=? fun (block_header, save_point, caboose, history_mode) ->
cctxt#message
"@[<v 0>Checkpoint: %s@,\
Checkpoint level: %ld@,\
History mode: %a@,\
Save point level: %ld@,\
Caboose level: %ld@]"
(Block_header.to_b58check block_header)
block_header.shell.level
History_mode.pp
history_mode
save_point
caboose
>>= fun () -> return ()) ]
src/lib_client_commands/client_admin_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition block_param {A B : Type}
(name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.Block_hash.t -> A) B :=
Clic.param name desc
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun str => Lwt._return (Block_hash.of_b58check str))) t.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
let group :=
{| name := "admin" % string;
title := "Commands to perform privileged operations on the node" % string
|} in
cons
(command (Some group)
"Make the node forget its decision of rejecting blocks." % string
no_options
(apply (prefixes (cons "unmark" % string (cons "invalid" % string [])))
(seq_of_param
(block_param "block" % string
"blocks to remove from invalid list" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
fun blocks =>
fun cctxt =>
iter_s
(fun block =>
op_gtgteqquestion
(Shell_services.Invalid_blocks.delete cctxt None block)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" no longer marked invalid." % string
CamlinternalFormatBasics.End_of_format)))
"Block %a no longer marked invalid." % string)
Block_hash.pp block)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) blocks))
(cons
(command (Some group)
"Make the node forget every decision of rejecting blocks." % string
no_options
(apply
(prefixes
(cons "unmark" % string
(cons "all" % string
(cons "invalid" % string (cons "blocks" % string []))))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Shell_services.Invalid_blocks.list cctxt None tt)
(fun invalid_blocks =>
iter_s
(fun function_parameter =>
let '{| Chain_services.hash := hash |} := function_parameter
in
op_gtgteqquestion
(Shell_services.Invalid_blocks.delete cctxt None hash)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" no longer marked invalid." % string
CamlinternalFormatBasics.End_of_format)))
"Block %a no longer marked invalid." % string)
Block_hash.pp_short hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) invalid_blocks)))
(cons
(command (Some group)
"Retrieve the current checkpoint and display it in a format compatible with node argument `--checkpoint`."
% string no_options
(fixed
(cons "show" % string
(cons "current" % string (cons "checkpoint" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
(Shell_services.Chain.checkpoint cctxt
(Some
(* ❌ Sending method message is not handled *)
send) tt)
(fun function_parameter =>
let '(block_header, save_point, caboose, history_mode) :=
function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Checkpoint: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"Checkpoint level: " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"History mode: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Save point level: " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Caboose level: " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[<v 0>Checkpoint: %s@,Checkpoint level: %ld@,History mode: %a@,Save point level: %ld@,Caboose level: %ld@]"
% string) (Block_header.to_b58check block_header)
(level (shell block_header)) History_mode.pp history_mode
save_point caboose)
(fun function_parameter =>
let 'tt := function_parameter in
_return tt)))) [])).
src/lib_client_commands/client_commands.ml 13 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_context
type command = full Clic.command
type network = [`Mainnet | `Alphanet | `Zeronet | `Sandbox]
exception Version_not_found
let versions = Protocol_hash.Table.create 7
let get_versions () =
Protocol_hash.Table.fold (fun k c acc -> (k, c) :: acc) versions []
let register name commands =
let previous =
try Protocol_hash.Table.find versions name
with Not_found -> fun (_network : network option) -> ([] : command list)
in
Protocol_hash.Table.replace versions name (fun (network : network option) ->
commands network @ previous network)
let commands_for_version version =
try Protocol_hash.Table.find versions version
with Not_found -> raise Version_not_found
src/lib_client_commands/client_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_context.
Definition command :=
Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full.
Definition network := variant.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition versions
: Tezos_base__TzPervasives.Protocol_hash.Table.t
((option network) -> list command) := Protocol_hash.Table.create 7.
Definition get_versions (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Protocol_hash.Table.key *
((option network) -> list command)) :=
let 'tt := function_parameter in
Protocol_hash.Table.fold (fun k => fun c => fun acc => cons (k, c) acc)
versions [].
Definition register
(name : Tezos_base__TzPervasives.Protocol_hash.Table.key)
(commands : (option network) -> list command) : unit :=
let previous :=
(* ❌ Try-with are not handled *)
try (Protocol_hash.Table.find versions name) in
Protocol_hash.Table.replace versions name
(fun network => OCaml.Stdlib.app (commands network) (previous network)).
Definition commands_for_version
(version : Tezos_base__TzPervasives.Protocol_hash.Table.key)
: (option network) -> list command :=
(* ❌ Try-with are not handled *)
try (Protocol_hash.Table.find versions version).
src/lib_client_commands/client_event_logging_commands.ml 92 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let group =
Clic.
{
name = "event-logging-framework";
title = "Commands to inspect the event-logging framework";
}
let date_parameter option_name build =
let open Clic in
parameter (fun _ s ->
let problem fmt = Printf.ksprintf invalid_arg fmt in
try
if String.length s <> 8 then problem "date should be `YYYYMMDD`" ;
String.iteri
(fun idx -> function '0' .. '9' -> () | other ->
problem "character %d is not a digit: '%c'." idx other)
s ;
let month = int_of_string (String.sub s 4 2) - 1 in
if month < 0 then problem "The month cannot be '00'" ;
if month > 11 then problem "The month cannot be more than '12'" ;
let day = int_of_string (String.sub s 6 2) in
if day > 31 then problem "The month cannot be more than '31'" ;
let t =
let tm =
Unix.
{
tm_sec = 0;
tm_min = 0;
tm_hour = 0;
tm_mday = day;
tm_mon = month;
tm_year = int_of_string (String.sub s 0 4) - 1900;
tm_wday = 0;
tm_yday = 0;
tm_isdst = false;
}
in
Unix.mktime tm |> fst
in
return (build t)
with
| Invalid_argument e ->
failwith "In `%s %S`, %s" option_name s e
| e ->
failwith "Exn: %a" pp_exn e)
let flat_pp pp o =
Format.(
asprintf
"%a"
(fun fmt () ->
pp_set_margin fmt 2_000_000 ;
pp fmt o)
())
let commands () =
let open Clic in
let command ~desc = command ~group ~desc in
[ command
~desc:"Query the events from an event sink."
(args7
(arg
~doc:"Filter on event names"
~long:"names"
~placeholder:"LIST"
(parameter (fun _ s ->
try return (String.split_on_char ',' s)
with _ -> failwith "List of names cannot be parsed")))
(arg
~doc:"Filter on event sections (use '_' for no-section)"
~long:"sections"
~placeholder:"LIST"
(parameter (fun _ s ->
try
return
( String.split_on_char ',' s
|> List.map (function "_" -> None | other -> Some other)
)
with _ -> failwith "List of sections cannot be parsed")))
(arg
~doc:"Filter out events before DATE"
~long:"since"
~placeholder:"DATE"
(date_parameter "--since" (fun s -> `Date (`Ge, s))))
(arg
~doc:"Filter out events after DATE"
~long:"until"
~placeholder:"DATE"
(date_parameter "--until" (fun s -> `Date (`Le, s))))
(switch
~doc:"Display events as JSON instead of pretty-printing them"
~long:"as-json"
())
(switch ~doc:"Try to display unknown events" ~long:"dump-unknown" ())
(Scriptable.clic_arg ()))
( prefixes ["query"; "events"; "from"]
@@ param
~name:"Sink-Name"
~desc:"The URI of the SINK to query"
(parameter (fun _ s ->
try return (Uri.of_string s)
with _ -> failwith "Uri cannot be parsed"))
@@ stop )
(fun ( only_names,
only_sections,
since,
until,
as_json,
dump_unknown,
scriptable )
uri
(cctxt : #Client_context.full) ->
let open Tezos_stdlib_unix in
match Uri.scheme uri with
| None | Some "unix-files" -> (
let script_row kind date evname data () =
[kind; date; evname; data]
in
Scriptable.output_for_human scriptable (fun () ->
cctxt#message "### Events" >>= fun () -> return_unit)
>>=? fun () ->
let on_unknown =
if not dump_unknown then None
else
Some
(fun path ->
Scriptable.output_row
scriptable
~for_human:(fun () ->
cctxt#message "Unknown: %s" path
>>= fun () ->
Lwt_stream.iter_s
(fun line -> cctxt#message " |%s" line)
(Lwt_io.lines_of_file path)
>>= fun () -> return_unit)
~for_script:(script_row "unknown-event" "-" "-" path))
in
let time_query =
match (since, until) with
| (None, None) ->
None
| (Some a, None) | (None, Some a) ->
Some a
| (Some a, Some b) ->
Some (`And (a, b))
in
File_event_sink.Query.fold
?only_names
?on_unknown
?only_sections
?time_query
uri
~init:()
~f:(fun () ~time_stamp ev ->
let o = Internal_event.Generic.explode_event ev in
let time_string time_value =
let open Unix in
let tm = gmtime time_value in
Printf.sprintf
"%04d%02d%02d-%02d%02d%02d-%04d"
(1900 + tm.tm_year)
(tm.tm_mon + 1)
tm.tm_mday
tm.tm_hour
tm.tm_min
tm.tm_sec
( (time_value -. floor time_value) *. 10_000.
|> int_of_float )
in
let pp fmt o =
if as_json then Data_encoding.Json.pp fmt o#json
else o#pp fmt ()
in
Scriptable.output_row
scriptable
~for_human:(fun () ->
cctxt#message
"@[<2>* [%s %s]@ %a@]"
(time_string time_stamp)
o#name
pp
o
>>= fun () -> return_unit)
~for_script:(fun () ->
let text = flat_pp pp o in
script_row "event" (time_string time_stamp) o#name text ()))
>>=? function
| ([], ()) ->
return_unit
| (errors_and_warnings, ()) ->
let open Format in
Scriptable.output
scriptable
~for_human:(fun () ->
cctxt#message
"### Some things were not perfect:@.@[<2>%a@]"
(pp_print_list
~pp_sep:(fun fmt () -> fprintf fmt "@.")
(fun fmt item ->
fprintf
fmt
"* %a"
File_event_sink.Query.Report.pp
item))
errors_and_warnings
>>= fun () -> return_unit)
~for_script:(fun () ->
let make_row e =
let text = flat_pp File_event_sink.Query.Report.pp e in
let tag =
match e with
| `Error _ ->
"error"
| `Warning _ ->
"warning"
in
script_row tag "-" "-" text ()
in
List.map make_row errors_and_warnings) )
| Some other ->
cctxt#message "URI scheme %S not handled as of now." other
>>= fun () -> return_unit);
command
~desc:
"Display configuration/state information about the internal-event \
logging framework."
no_options
(prefixes ["show"; "event-logging"] @@ stop)
(fun () (cctxt : #Client_context.full) ->
let pp_event_definitions fmt schs =
let open Format in
pp_open_box fmt 0 ;
pp_print_list
~pp_sep:(fun fmt () -> fprintf fmt "@;")
(fun fmt obj_schema ->
pp_open_box fmt 2 ;
fprintf fmt "* `%s`:@ " obj_schema#name ;
pp_print_text fmt obj_schema#doc ;
pp_close_box fmt ())
fmt
schs ;
pp_close_box fmt ()
in
cctxt#message
"Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a"
Internal_event.All_sinks.pp_state
()
pp_event_definitions
Internal_event.(
All_definitions.get () |> List.map Generic.json_schema)
>>= fun () -> return_unit);
command
~desc:"Output the JSON schema of an internal-event."
no_options
( prefixes ["output"; "schema"; "of"]
@@ param
~name:"Event-Name"
~desc:"Name of the event"
(parameter (fun _ s -> return s))
@@ prefix "to"
@@ param
~name:"File-path"
~desc:"Path to a JSON file"
(parameter (fun _ s -> return s))
@@ stop )
(fun () event path (cctxt : #Client_context.full) ->
let open Internal_event in
match All_definitions.find (( = ) event) with
| None ->
failwith "Event %S not found" event
| Some ev ->
let o = Generic.json_schema ev in
Lwt_io.with_file ~mode:Lwt_io.output path (fun chan ->
let v = Format.asprintf "%a" Json_schema.pp o#schema in
Lwt_io.write chan v)
>>= fun () ->
cctxt#message "Wrote schema of %s to %s" event path
>>= fun () -> return_unit) ]
src/lib_client_commands/client_event_logging_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| name := "event-logging-framework" % string;
title := "Commands to inspect the event-logging framework" % string |}.
Definition date_parameter {A B : Type} (option_name : string) (build : Z -> A)
: Tezos_base__TzPervasives.Clic.parameter A B :=
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
let problem {C D : Type} (fmt : Stdlib.format4 C unit string D) : C :=
Printf.ksprintf OCaml.Stdlib.invalid_arg fmt in
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
if nequiv_decb (String.length s) 8 then
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"date should be `YYYYMMDD`" % string
CamlinternalFormatBasics.End_of_format)
"date should be `YYYYMMDD`" % string)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
String.iteri
(fun idx =>
fun function_parameter =>
match function_parameter with
|
"0" % char |
"1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char |
"6" % char |
"7" % char | "8" % char | "9" % char => tt
| other =>
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"character " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" is not a digit: '" % string
(CamlinternalFormatBasics.Char
(CamlinternalFormatBasics.String_literal
"'." % string
CamlinternalFormatBasics.End_of_format)))))
"character %d is not a digit: '%c'." % string) idx other
end) s in
let month := Z.sub (OCaml.Stdlib.int_of_string (String.sub s 4 2)) 1
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt month 0 then
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The month cannot be '00'" % string
CamlinternalFormatBasics.End_of_format)
"The month cannot be '00'" % string)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt month 11 then
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The month cannot be more than '12'" % string
CamlinternalFormatBasics.End_of_format)
"The month cannot be more than '12'" % string)
else
tt in
let day := OCaml.Stdlib.int_of_string (String.sub s 6 2) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt day 31 then
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The month cannot be more than '31'" % string
CamlinternalFormatBasics.End_of_format)
"The month cannot be more than '31'" % string)
else
tt in
let t :=
let tm :=
{| tm_sec := 0; tm_min := 0; tm_hour := 0; tm_mday := day;
tm_mon := month;
tm_year :=
Z.sub (OCaml.Stdlib.int_of_string (String.sub s 0 4)) 1900;
tm_wday := 0; tm_yday := 0; tm_isdst := false |} in
OCaml.Stdlib.reverse_apply (Unix.mktime tm) fst in
_return (build t))).
Definition flat_pp {A : Type}
(pp : Stdlib.Format.formatter -> A -> unit) (o : A) : string :=
asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string)
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_set_margin fmt 2000000 in
pp fmt o) tt.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
let command {J K L : Type} (desc : string)
: (Tezos_base__TzPervasives.Clic.options J K) ->
(Tezos_base__TzPervasives.Clic.params L K) ->
(J -> L) -> Tezos_base__TzPervasives.Clic.command K :=
command (Some group) desc in
cons
(command "Query the events from an event sink." % string
(args7
(arg "Filter on event names" % string None "names" % string
"LIST" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (String.split_on_char "," % char s)))))
(arg "Filter on event sections (use '_' for no-section)" % string None
"sections" % string "LIST" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(_return
(OCaml.Stdlib.reverse_apply
(String.split_on_char "," % char s)
(List.map
(fun function_parameter =>
match function_parameter with
| "_" % string => None
| other => Some other
end)))))))
(arg "Filter out events before DATE" % string None "since" % string
"DATE" % string
(date_parameter "--since" % string
(fun s =>
(* ❌ Variants not supported *)
variant)))
(arg "Filter out events after DATE" % string None "until" % string
"DATE" % string
(date_parameter "--until" % string
(fun s =>
(* ❌ Variants not supported *)
variant)))
(switch
"Display events as JSON instead of pretty-printing them" % string None
"as-json" % string tt)
(switch "Try to display unknown events" % string None
"dump-unknown" % string tt) (Scriptable.clic_arg tt))
(apply
(prefixes
(cons "query" % string
(cons "events" % string (cons "from" % string []))))
(apply
(param "Sink-Name" % string "The URI of the SINK to query" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (Uri.of_string s))))) stop))
(fun function_parameter =>
let
'(only_names, only_sections, since, until, as_json, dump_unknown,
scriptable) := function_parameter in
fun uri =>
fun cctxt =>
match Uri.scheme uri with
| None | Some "unix-files" % string =>
let script_row {J : Type}
(kind : J) (date : J) (evname : J) (data : J)
(function_parameter : unit) : list J :=
let 'tt := function_parameter in
cons kind (cons date (cons evname (cons data []))) in
op_gtgteqquestion
(Scriptable.output_for_human scriptable
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"### Events" % string
CamlinternalFormatBasics.End_of_format)
"### Events" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(fun function_parameter =>
let 'tt := function_parameter in
let on_unknown :=
if negb dump_unknown then
None
else
Some
(fun path =>
Scriptable.output_row None scriptable
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Unknown: %s" % string) path)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_stream.iter_s
(fun line =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" |" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
" |%s" % string) line)
(Lwt_io.lines_of_file path))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(script_row "unknown-event" % string "-" % string
"-" % string path)) in
let time_query :=
match (since, until) with
| (None, None) => None
| (Some a, None) | (None, Some a) => Some a
| (Some a, Some b) =>
Some
(* ❌ Variants not supported *)
variant
end in
op_gtgteqquestion
(File_event_sink.Query.fold on_unknown only_sections
only_names time_query uri tt
(fun function_parameter =>
let 'tt := function_parameter in
fun time_stamp =>
fun ev =>
let o := Internal_event.Generic.explode_event ev in
let time_string (time_value : Z) : string :=
let tm := gmtime time_value in
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 4)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
"-" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros
2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
"-" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros
4)
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))))))
"%04d%02d%02d-%02d%02d%02d-%04d" % string)
(Z.add 1900 (tm_year tm)) (Z.add (tm_mon tm) 1)
(tm_mday tm) (tm_hour tm) (tm_min tm)
(tm_sec tm)
(OCaml.Stdlib.reverse_apply
(Stdlib.op_starpoint
(Stdlib.op_minuspoint time_value
(Stdlib.floor time_value))
(* ❌ Float constant 10_000. is approximated by the integer 10000 *)
10000) Stdlib.int_of_float) in
let pp {J : Type}
(fmt : Stdlib.Format.formatter) (o :
(Tezos_data_encoding.Data_encoding.Json.json *
((Stdlib.Format.formatter -> unit -> unit) * J)))
: unit :=
if as_json then
Data_encoding.Json.pp fmt
(* ❌ Sending method message is not handled *)
send
else
(* ❌ Sending method message is not handled *)
send fmt tt in
Scriptable.output_row None scriptable
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<2>" % string
CamlinternalFormatBasics.End_of_format)
"<2>" % string))
(CamlinternalFormatBasics.String_literal
"* [" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"]" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<2>* [%s %s]@ %a@]" % string)
(time_string time_stamp)
(* ❌ Sending method message is not handled *)
send pp o)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
(fun function_parameter =>
let 'tt := function_parameter in
let text := flat_pp pp o in
script_row "event" % string
(time_string time_stamp)
(* ❌ Sending method message is not handled *)
send text tt)))
(fun function_parameter =>
match function_parameter with
| ([], tt) => return_unit
| (errors_and_warnings, tt) =>
Scriptable.output None scriptable
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"### Some things were not perfect:" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<2>" % string
CamlinternalFormatBasics.End_of_format)
"<2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"### Some things were not perfect:@.@[<2>%a@]"
% string)
(pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)
"@." % string)))
(fun fmt =>
fun item =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"* %a" % string)
File_event_sink.Query.Report.pp item))
errors_and_warnings)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
(fun function_parameter =>
let 'tt := function_parameter in
let make_row
(e :
Tezos_stdlib_unix.File_event_sink.Query.Report.item)
: list string :=
let text :=
flat_pp File_event_sink.Query.Report.pp e in
let tag :=
match e with
| Error _ => "error" % string
| Warning _ => "warning" % string
end in
script_row tag "-" % string "-" % string text tt
in
List.map make_row errors_and_warnings)
end))
| Some other =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"URI scheme " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" not handled as of now." % string
CamlinternalFormatBasics.End_of_format)))
"URI scheme %S not handled as of now." % string) other)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
(cons
(command
"Display configuration/state information about the internal-event logging framework."
% string no_options
(apply
(prefixes (cons "show" % string (cons "event-logging" % string [])))
stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
let pp_event_definitions {J : Type}
(fmt : Stdlib.Format.formatter) (schs :
list ((string * (string * J)))) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_box fmt 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@;" % string 1 0)
CamlinternalFormatBasics.End_of_format)
"@;" % string)))
(fun fmt =>
fun obj_schema =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_box fmt 2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"`:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
CamlinternalFormatBasics.End_of_format))))
"* `%s`:@ " % string)
(* ❌ Sending method message is not handled *)
send in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_text fmt
(* ❌ Sending method message is not handled *)
send in
pp_close_box fmt tt) fmt schs in
pp_close_box fmt tt in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Event logging framework:" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"Sinks state:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"Events registered:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))))))
"Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a"
% string) Internal_event.All_sinks.pp_state tt
pp_event_definitions
(OCaml.Stdlib.reverse_apply (All_definitions.get tt)
(List.map Generic.json_schema)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command "Output the JSON schema of an internal-event." % string
no_options
(apply
(prefixes
(cons "output" % string
(cons "schema" % string (cons "of" % string []))))
(apply
(param "Event-Name" % string "Name of the event" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)))
(apply (prefix "to" % string)
(apply
(param "File-path" % string "Path to a JSON file" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s))) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun event =>
fun path =>
fun cctxt =>
match All_definitions.find (equiv_decb event) with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Event " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" not found" % string
CamlinternalFormatBasics.End_of_format)))
"Event %S not found" % string) event
| Some ev =>
let o := Generic.json_schema ev in
op_gtgteq
(Lwt_io.with_file None None None Lwt_io.output path
(fun chan =>
let v :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Json_schema.pp
(* ❌ Sending method message is not handled *)
send in
Lwt_io.write chan v))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Wrote schema of " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" to " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Wrote schema of %s to %s" % string) event path)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
end)) [])).
src/lib_client_commands/client_helpers_commands.ml 82 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let unique_switch =
Clic.switch
~long:"unique"
~short:'u'
~doc:"Fail when there is more than one possible completion."
()
let commands () =
Clic.
[ command
~desc:
"Autocomplete a prefix of Base58Check-encoded hash.\n\
This actually works only for blocks, operations, public key and \
contract identifiers."
(args1 unique_switch)
( prefixes ["complete"]
@@ string ~name:"prefix" ~desc:"the prefix of the hash to complete"
@@ stop )
(fun unique prefix (cctxt : #Client_context.full) ->
Shell_services.Blocks.Helpers.complete
cctxt
~chain:cctxt#chain
~block:cctxt#block
prefix
>>=? fun completions ->
match completions with
| [] ->
Pervasives.exit 3
| _ :: _ :: _ when unique ->
Pervasives.exit 3
| completions ->
List.iter print_endline completions ;
return_unit);
command
~desc:"Wait for the node to be bootstrapped."
no_options
(prefixes ["bootstrapped"] @@ stop)
(fun () (cctxt : #Client_context.full) ->
Monitor_services.bootstrapped cctxt
>>=? fun (stream, _) ->
Lwt_stream.iter_s
(fun (hash, time) ->
cctxt#message
"Current head: %a (timestamp: %a, validation: %a)"
Block_hash.pp_short
hash
Time.System.pp_hum
(Time.System.of_protocol_exn time)
Time.System.pp_hum
(Tezos_stdlib_unix.Systime_os.now ()))
stream
>>= fun () -> cctxt#answer "Bootstrapped." >>= fun () -> return_unit)
]
src/lib_client_commands/client_helpers_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition unique_switch {F G I a b i o p q : Type}
: Tezos_base__TzPervasives.Clic.arg bool
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
Clic.switch "Fail when there is more than one possible completion." % string
(Some "u" % char) "unique" % string tt.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
cons
(command None
"Autocomplete a prefix of Base58Check-encoded hash.
This actually works only for blocks, operations, public key and contract identifiers."
% string (args1 unique_switch)
(apply (prefixes (cons "complete" % string []))
(apply
(string "prefix" % string
"the prefix of the hash to complete" % string) stop))
(fun unique =>
fun prefix =>
fun cctxt =>
op_gtgteqquestion
(Shell_services.Blocks.Helpers.complete cctxt
(Some
(* ❌ Sending method message is not handled *)
send)
(Some
(* ❌ Sending method message is not handled *)
send) prefix)
(fun completions =>
match completions with
| [] => Pervasives.exit 3
| cons _ (cons _ _) => Pervasives.exit 3
| completions =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter OCaml.Stdlib.print_endline completions in
return_unit
end)))
(cons
(command None "Wait for the node to be bootstrapped." % string no_options
(apply (prefixes (cons "bootstrapped" % string [])) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Monitor_services.bootstrapped cctxt)
(fun function_parameter =>
let '(stream, _) := function_parameter in
op_gtgteq
(Lwt_stream.iter_s
(fun function_parameter =>
let '(hash, time) := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Current head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (timestamp: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", validation: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Current head: %a (timestamp: %a, validation: %a)" %
string) Block_hash.pp_short hash Time.System.pp_hum
(Time.System.of_protocol_exn time) Time.System.pp_hum
(Tezos_stdlib_unix.Systime_os.now tt)) stream)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bootstrapped." % string
CamlinternalFormatBasics.End_of_format)
"Bootstrapped." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))) []).
src/lib_client_commands/client_keys_commands.ml 168 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_keys
let group =
{
Clic.name = "keys";
title = "Commands for managing the wallet of cryptographic keys";
}
let algo_param () =
Clic.parameter
~autocomplete:(fun _ -> return ["ed25519"; "secp256k1"; "p256"])
(fun _ name ->
match name with
| "ed25519" ->
return Signature.Ed25519
| "secp256k1" ->
return Signature.Secp256k1
| "p256" ->
return Signature.P256
| name ->
failwith
"Unknown signature algorithm (%s). Available: 'ed25519', \
'secp256k1' or 'p256'"
name)
let sig_algo_arg =
Clic.default_arg
~doc:"use custom signature algorithm"
~long:"sig"
~short:'s'
~placeholder:"ed25519|secp256k1|p256"
~default:"ed25519"
(algo_param ())
let gen_keys_containing ?(encrypted = false) ?(prefix = false) ?(force = false)
~containing ~name (cctxt : #Client_context.io_wallet) =
let unrepresentable =
List.filter
(fun s ->
not @@ Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s)
containing
in
let good_initial_char = "KLMNPQRSTUVWXYZabcdefghi" in
let bad_initial_char = "123456789ABCDEFGHJjkmnopqrstuvwxyz" in
match unrepresentable with
| _ :: _ ->
cctxt#error
"@[<v 0>The following words can't be written in the key alphabet: %a.@,\
Valid characters: %a@,\
Extra restriction for the first character: %s@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
(fun ppf s -> Format.fprintf ppf "'%s'" s))
unrepresentable
Base58.Alphabet.pp
Base58.Alphabet.bitcoin
good_initial_char
| [] -> (
let unrepresentable =
List.filter
(fun s -> prefix && String.contains bad_initial_char s.[0])
containing
in
match unrepresentable with
| _ :: _ ->
cctxt#error
"@[<v 0>The following words don't respect the first character \
restriction: %a.@,\
Valid characters: %a@,\
Extra restriction for the first character: %s@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
(fun ppf s -> Format.fprintf ppf "'%s'" s))
unrepresentable
Base58.Alphabet.pp
Base58.Alphabet.bitcoin
good_initial_char
| [] ->
Public_key_hash.mem cctxt name
>>=? fun name_exists ->
if name_exists && not force then
cctxt#warning
"Key for name '%s' already exists. Use --force to update."
name
>>= return
else
cctxt#warning
"This process uses a brute force search and may take a long \
time to find a key."
>>= fun () ->
let matches =
if prefix then
let containing_tz1 = List.map (( ^ ) "tz1") containing in
fun key ->
List.exists
(fun containing ->
String.sub key 0 (String.length containing) = containing)
containing_tz1
else
let re = Re.Str.regexp (String.concat "\\|" containing) in
fun key ->
try
ignore (Re.Str.search_forward re key 0) ;
true
with Not_found -> false
in
let rec loop attempts =
let (public_key_hash, public_key, secret_key) =
Signature.generate_key ()
in
let hash =
Signature.Public_key_hash.to_b58check
@@ Signature.Public_key.hash public_key
in
if matches hash then
let pk_uri =
Tezos_signer_backends.Unencrypted.make_pk public_key
in
( if encrypted then
Tezos_signer_backends.Encrypted.encrypt cctxt secret_key
else
return (Tezos_signer_backends.Unencrypted.make_sk secret_key)
)
>>=? fun sk_uri ->
register_key
cctxt
~force
(public_key_hash, pk_uri, sk_uri)
name
>>=? fun () -> return hash
else
( if attempts mod 25_000 = 0 then
cctxt#message
"Tried %d keys without finding a match"
attempts
else Lwt.return_unit )
>>= fun () ->
Lwt_unix.yield () >>= fun () -> loop (attempts + 1)
in
loop 1
>>=? fun key_hash ->
cctxt#message "Generated '%s' under the name '%s'." key_hash name
>>= fun () -> return_unit )
let rec input_fundraiser_params (cctxt : #Client_context.io_wallet) =
let rec get_boolean_answer (cctxt : #Client_context.io_wallet) ~default ~msg
=
let prompt = if default then "(Y/n/q)" else "(y/N/q)" in
cctxt#prompt "%s %s: " msg prompt
>>=? fun gen ->
match (default, String.lowercase_ascii gen) with
| (default, "") ->
return default
| (_, "y") ->
return_true
| (_, "n") ->
return_false
| (_, "q") ->
failwith "Exit by user request."
| _ ->
get_boolean_answer cctxt ~msg ~default
in
cctxt#prompt "Enter the e-mail used for the paper wallet: "
>>=? fun email ->
let rec loop_words acc i =
if i > 14 then return (List.rev acc)
else
cctxt#prompt_password "Enter word %d: " i
>>=? fun word ->
match Bip39.index_of_word (Bigstring.to_string word) with
| None ->
loop_words acc i
| Some wordidx ->
loop_words (wordidx :: acc) (succ i)
in
loop_words [] 0
>>=? fun words ->
match Bip39.of_indices words with
| None ->
assert false
| Some t -> (
cctxt#prompt_password "Enter the password used for the paper wallet: "
>>=? fun password ->
(* TODO: unicode normalization (NFKD)... *)
let passphrase = Bigstring.(concat "" [of_string email; password]) in
let sk = Bip39.to_seed ~passphrase t in
let sk = Bigstring.sub_bytes sk 0 32 in
let sk : Signature.Secret_key.t =
Ed25519
(Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
in
let pk = Signature.Secret_key.to_public_key sk in
let pkh = Signature.Public_key.hash pk in
let msg =
Format.asprintf
"Your public Tezos address is %a is that correct?"
Signature.Public_key_hash.pp
pkh
in
get_boolean_answer cctxt ~msg ~default:true
>>=? function
| true -> return sk | false -> input_fundraiser_params cctxt )
let commands version : Client_context.full Clic.command list =
let open Clic in
let encrypted_switch () =
if
List.exists
(fun (scheme, _) -> scheme = Tezos_signer_backends.Unencrypted.scheme)
(Client_keys.registered_signers ())
then Clic.switch ~long:"encrypted" ~doc:"Encrypt the key on-disk" ()
else Clic.constant true
in
let show_private_switch =
switch ~long:"show-secret" ~short:'S' ~doc:"show the private key" ()
in
[ command
~group
~desc:
"List supported signing schemes.\n\
Signing schemes are identifiers for signer modules: the built-in \
signing routines, a hardware wallet, an external agent, etc.\n\
Each signer has its own format for describing secret keys, such a \
raw secret key for the default `unencrypted` scheme, the path on a \
hardware security module, an alias for an external agent, etc.\n\
This command gives the list of signer modules that this version of \
the tezos client supports."
no_options
(fixed ["list"; "signing"; "schemes"])
(fun () (cctxt : Client_context.full) ->
let signers =
List.sort
(fun (ka, _) (kb, _) -> String.compare ka kb)
(registered_signers ())
in
Lwt_list.iter_s
(fun (n, (module S : SIGNER)) ->
cctxt#message
"@[<v 2>Scheme `%s`: %s@,@[<hov 0>%a@]@]"
n
S.title
Format.pp_print_text
S.description)
signers
>>= return);
( match version with
| Some `Mainnet ->
command
~group
~desc:"Generate a pair of keys."
(args2 (Secret_key.force_switch ()) sig_algo_arg)
(prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop)
(fun (force, algo) name (cctxt : Client_context.full) ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
let (pkh, pk, sk) = Signature.generate_key ~algo () in
let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
Tezos_signer_backends.Encrypted.encrypt cctxt sk
>>=? fun sk_uri ->
register_key cctxt ~force (pkh, pk_uri, sk_uri) name)
| _ ->
command
~group
~desc:"Generate a pair of keys."
(args3
(Secret_key.force_switch ())
sig_algo_arg
(encrypted_switch ()))
(prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop)
(fun (force, algo, encrypted) name (cctxt : Client_context.full) ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
let (pkh, pk, sk) = Signature.generate_key ~algo () in
let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
( if encrypted then Tezos_signer_backends.Encrypted.encrypt cctxt sk
else return (Tezos_signer_backends.Unencrypted.make_sk sk) )
>>=? fun sk_uri ->
register_key cctxt ~force (pkh, pk_uri, sk_uri) name) );
( match version with
| Some `Mainnet ->
command
~group
~desc:"Generate keys including the given string."
(args2
(switch
~long:"prefix"
~short:'P'
~doc:"the key must begin with tz1[word]"
())
(force_switch ()))
( prefixes ["gen"; "vanity"; "keys"]
@@ Public_key_hash.fresh_alias_param @@ prefix "matching"
@@ seq_of_param
@@ string
~name:"words"
~desc:"string key must contain one of these words" )
(fun (prefix, force) name containing (cctxt : Client_context.full) ->
Public_key_hash.of_fresh cctxt force name
>>=? fun name ->
gen_keys_containing
~encrypted:true
~force
~prefix
~containing
~name
cctxt)
| _ ->
command
~group
~desc:"Generate keys including the given string."
(args3
(switch
~long:"prefix"
~short:'P'
~doc:"the key must begin with tz1[word]"
())
(force_switch ())
(encrypted_switch ()))
( prefixes ["gen"; "vanity"; "keys"]
@@ Public_key_hash.fresh_alias_param @@ prefix "matching"
@@ seq_of_param
@@ string
~name:"words"
~desc:"string key must contain one of these words" )
(fun (prefix, force, encrypted)
name
containing
(cctxt : Client_context.full) ->
Public_key_hash.of_fresh cctxt force name
>>=? fun name ->
gen_keys_containing
~encrypted
~force
~prefix
~containing
~name
cctxt) );
command
~group
~desc:"Encrypt an unencrypted secret key."
no_options
(prefixes ["encrypt"; "secret"; "key"] @@ stop)
(fun () (cctxt : Client_context.full) ->
cctxt#prompt_password "Enter unencrypted secret key: "
>>=? fun sk_uri ->
let sk_uri = Uri.of_string (Bigstring.to_string sk_uri) in
( match Uri.scheme sk_uri with
| None | Some "unencrypted" ->
return_unit
| _ ->
failwith
"This command can only be used with the \"unencrypted\" scheme"
)
>>=? fun () ->
Lwt.return (Signature.Secret_key.of_b58check (Uri.path sk_uri))
>>=? fun sk ->
Tezos_signer_backends.Encrypted.encrypt cctxt sk
>>=? fun sk_uri ->
cctxt#message "Encrypted secret key %a" Uri.pp_hum (sk_uri :> Uri.t)
>>= fun () -> return_unit);
command
~group
~desc:"Add a secret key to the wallet."
(args1 (Secret_key.force_switch ()))
( prefix "import"
@@ prefixes ["secret"; "key"]
@@ Secret_key.fresh_alias_param @@ Client_keys.sk_uri_param @@ stop )
(fun force name sk_uri (cctxt : Client_context.full) ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
Client_keys.neuterize sk_uri
>>=? fun pk_uri ->
Public_key.find_opt cctxt name
>>=? (function
| None ->
return_unit
| Some (pk_uri_found, _) ->
fail_unless
(pk_uri = pk_uri_found || force)
(failure
"public and secret keys '%s' don't correspond, please \
don't use --force"
name))
>>=? fun () ->
Client_keys.import_secret_key
~io:(cctxt :> Client_context.io_wallet)
pk_uri
>>=? fun (pkh, public_key) ->
cctxt#message
"Tezos address added: %a"
Signature.Public_key_hash.pp
pkh
>>= fun () ->
register_key cctxt ~force (pkh, pk_uri, sk_uri) ?public_key name) ]
@ ( if version <> Some `Mainnet then []
else
[ command
~group
~desc:"Add a fundraiser secret key to the wallet."
(args1 (Secret_key.force_switch ()))
( prefix "import"
@@ prefixes ["fundraiser"; "secret"; "key"]
@@ Secret_key.fresh_alias_param @@ stop )
(fun force name (cctxt : Client_context.full) ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
input_fundraiser_params cctxt
>>=? fun sk ->
Tezos_signer_backends.Encrypted.encrypt cctxt sk
>>=? fun sk_uri ->
Client_keys.neuterize sk_uri
>>=? fun pk_uri ->
Public_key.find_opt cctxt name
>>=? (function
| None ->
return_unit
| Some (pk_uri_found, _) ->
fail_unless
(pk_uri = pk_uri_found || force)
(failure
"public and secret keys '%s' don't correspond, \
please don't use --force"
name))
>>=? fun () ->
Client_keys.public_key_hash pk_uri
>>=? fun (pkh, _public_key) ->
register_key cctxt ~force (pkh, pk_uri, sk_uri) name) ] )
@ [ command
~group
~desc:"Add a public key to the wallet."
(args1 (Public_key.force_switch ()))
( prefix "import"
@@ prefixes ["public"; "key"]
@@ Public_key.fresh_alias_param @@ Client_keys.pk_uri_param @@ stop )
(fun force name pk_uri (cctxt : Client_context.full) ->
Public_key.of_fresh cctxt force name
>>=? fun name ->
Client_keys.public_key_hash pk_uri
>>=? fun (pkh, public_key) ->
Public_key_hash.add ~force cctxt name pkh
>>=? fun () ->
cctxt#message
"Tezos address added: %a"
Signature.Public_key_hash.pp
pkh
>>= fun () -> Public_key.add ~force cctxt name (pk_uri, public_key));
command
~group
~desc:"Add an address to the wallet."
(args1 (Public_key.force_switch ()))
( prefixes ["add"; "address"]
@@ Public_key_hash.fresh_alias_param @@ Public_key_hash.source_param
@@ stop )
(fun force name hash cctxt ->
Public_key_hash.of_fresh cctxt force name
>>=? fun name -> Public_key_hash.add ~force cctxt name hash);
command
~group
~desc:"List all addresses and associated keys."
no_options
(fixed ["list"; "known"; "addresses"])
(fun () (cctxt : #Client_context.full) ->
list_keys cctxt
>>=? fun l ->
iter_s
(fun (name, pkh, pk, sk) ->
Public_key_hash.to_source pkh
>>=? fun v ->
( match (pk, sk) with
| (None, None) ->
cctxt#message "%s: %s" name v
| (_, Some uri) ->
let scheme =
Option.unopt ~default:"unencrypted"
@@ Uri.scheme (uri : sk_uri :> Uri.t)
in
cctxt#message "%s: %s (%s sk known)" name v scheme
| (Some _, _) ->
cctxt#message "%s: %s (pk known)" name v )
>>= fun () -> return_unit)
l);
command
~group
~desc:"Show the keys associated with an implicit account."
(args1 show_private_switch)
(prefixes ["show"; "address"] @@ Public_key_hash.alias_param @@ stop)
(fun show_private (name, _) (cctxt : #Client_context.full) ->
alias_keys cctxt name
>>=? fun key_info ->
match key_info with
| None ->
cctxt#message "No keys found for address"
>>= fun () -> return_unit
| Some (pkh, pk, skloc) -> (
cctxt#message "Hash: %a" Signature.Public_key_hash.pp pkh
>>= fun () ->
match pk with
| None ->
return_unit
| Some pk ->
cctxt#message "Public Key: %a" Signature.Public_key.pp pk
>>= fun () ->
if show_private then
match skloc with
| None ->
return_unit
| Some skloc ->
Secret_key.to_source skloc
>>=? fun skloc ->
cctxt#message "Secret Key: %s" skloc
>>= fun () -> return_unit
else return_unit ));
command
~group
~desc:"Forget one address."
(args1
(Clic.switch
~long:"force"
~short:'f'
~doc:"delete associated keys when present"
()))
(prefixes ["forget"; "address"] @@ Public_key_hash.alias_param @@ stop)
(fun force (name, _pkh) (cctxt : Client_context.full) ->
Secret_key.mem cctxt name
>>=? fun has_secret_key ->
Public_key.mem cctxt name
>>=? fun has_public_key ->
fail_when
((not force) && (has_secret_key || has_public_key))
(failure
"secret or public key present for %s, use --force to delete"
name)
>>=? fun () ->
Secret_key.del cctxt name
>>=? fun () ->
Public_key.del cctxt name
>>=? fun () -> Public_key_hash.del cctxt name);
command
~group
~desc:"Forget the entire wallet of keys."
(args1
(Clic.switch
~long:"force"
~short:'f'
~doc:"you got to use the force for that"
()))
(fixed ["forget"; "all"; "keys"])
(fun force (cctxt : Client_context.full) ->
fail_unless
force
(failure "this can only be used with option --force")
>>=? fun () ->
Public_key.set cctxt []
>>=? fun () ->
Secret_key.set cctxt [] >>=? fun () -> Public_key_hash.set cctxt []);
command
~group
~desc:"Compute deterministic nonce."
no_options
( prefixes ["generate"; "nonce"; "for"]
@@ Public_key_hash.alias_param
@@ prefixes ["from"]
@@ string
~name:"data"
~desc:"string from which to deterministically generate the nonce"
@@ stop )
(fun () (name, _pkh) data (cctxt : Client_context.full) ->
let data = Bytes.of_string data in
Secret_key.mem cctxt name
>>=? fun sk_present ->
fail_unless sk_present (failure "secret key not present for %s" name)
>>=? fun () ->
Secret_key.find cctxt name
>>=? fun sk_uri ->
Client_keys.deterministic_nonce sk_uri data
>>=? fun nonce ->
cctxt#message "%a" Hex.pp (Hex.of_bytes (Bigstring.to_bytes nonce))
>>= fun () -> return_unit);
command
~group
~desc:"Compute deterministic nonce hash."
no_options
( prefixes ["generate"; "nonce"; "hash"; "for"]
@@ Public_key_hash.alias_param
@@ prefixes ["from"]
@@ string
~name:"data"
~desc:
"string from which to deterministically generate the nonce hash"
@@ stop )
(fun () (name, _pkh) data (cctxt : Client_context.full) ->
let data = Bytes.of_string data in
Secret_key.mem cctxt name
>>=? fun sk_present ->
fail_unless sk_present (failure "secret key not present for %s" name)
>>=? fun () ->
Secret_key.find cctxt name
>>=? fun sk_uri ->
Client_keys.deterministic_nonce_hash sk_uri data
>>=? fun nonce_hash ->
cctxt#message "%a" Hex.pp (Hex.of_bytes nonce_hash)
>>= fun () -> return_unit) ]
src/lib_client_commands/client_keys_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_keys.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "keys" % string;
Clic.title :=
"Commands for managing the wallet of cryptographic keys" % string |}.
Definition algo_param {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter
Tezos_base__TzPervasives.Signature.algo A :=
let 'tt := function_parameter in
Clic.parameter
(Some
(fun function_parameter =>
let '_ := function_parameter in
_return
(cons "ed25519" % string
(cons "secp256k1" % string (cons "p256" % string [])))))
(fun function_parameter =>
let '_ := function_parameter in
fun name =>
match name with
| "ed25519" % string =>
_return Tezos_base__TzPervasives.Signature.Ed25519
| "secp256k1" % string =>
_return Tezos_base__TzPervasives.Signature.Secp256k1
| "p256" % string => _return Tezos_base__TzPervasives.Signature.P256
| name =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown signature algorithm (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"). Available: 'ed25519', 'secp256k1' or 'p256'" % string
CamlinternalFormatBasics.End_of_format)))
"Unknown signature algorithm (%s). Available: 'ed25519', 'secp256k1' or 'p256'"
% string) name
end).
Definition sig_algo_arg
: Tezos_base__TzPervasives.Clic.arg Tezos_base__TzPervasives.Signature.algo
Tezos_client_base.Client_context.full :=
Clic.default_arg "use custom signature algorithm" % string (Some "s" % char)
"sig" % string "ed25519|secp256k1|p256" % string "ed25519" % string
(algo_param tt).
Definition gen_keys_containing {C a b : Type} (op_staroptstar : option bool)
: (option bool) ->
(option bool) ->
(list string) ->
string ->
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * C)))))))))))) * C) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let encrypted :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let prefix :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun containing =>
fun name =>
fun cctxt =>
let unrepresentable :=
List.filter
(fun s =>
apply negb
(Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s))
containing in
let good_initial_char := "KLMNPQRSTUVWXYZabcdefghi" % string in
let bad_initial_char :=
"123456789ABCDEFGHJjkmnopqrstuvwxyz" % string in
match unrepresentable with
| cons _ _ =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"The following words can't be written in the key alphabet: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Valid characters: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.String_literal
"Extra restriction for the first character: "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))
"@[<v 0>The following words can't be written in the key alphabet: %a.@,Valid characters: %a@,Extra restriction for the first character: %s@]"
% string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
", " % string
CamlinternalFormatBasics.End_of_format)
", " % string)))
(fun ppf =>
fun s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "'" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "'" % char
CamlinternalFormatBasics.End_of_format)))
"'%s'" % string) s)) unrepresentable
Base58.Alphabet.pp Base58.Alphabet.bitcoin good_initial_char
| [] =>
let unrepresentable :=
List.filter
(fun s =>
andb prefix
(String.contains bad_initial_char (String.get s 0)))
containing in
match unrepresentable with
| cons _ _ =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"The following words don't respect the first character restriction: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Valid characters: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Extra restriction for the first character: "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))
"@[<v 0>The following words don't respect the first character restriction: %a.@,Valid characters: %a@,Extra restriction for the first character: %s@]"
% string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
", " % string
CamlinternalFormatBasics.End_of_format)
", " % string)))
(fun ppf =>
fun s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "'" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"'%s'" % string) s)) unrepresentable
Base58.Alphabet.pp Base58.Alphabet.bitcoin good_initial_char
| [] =>
op_gtgteqquestion (Public_key_hash.mem cctxt name)
(fun name_exists =>
if andb name_exists (negb force) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Key for name '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"' already exists. Use --force to update." %
string
CamlinternalFormatBasics.End_of_format)))
"Key for name '%s' already exists. Use --force to update."
% string) name) _return
else
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This process uses a brute force search and may take a long time to find a key."
% string CamlinternalFormatBasics.End_of_format)
"This process uses a brute force search and may take a long time to find a key."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
let matches :=
if prefix then
let containing_tz1 :=
List.map (String.append "tz1" % string)
containing in
fun key =>
List._exists
(fun containing =>
equiv_decb
(String.sub key 0
(String.length containing)) containing)
containing_tz1
else
let re :=
Re.Str.regexp
(String.concat "\|" % string containing) in
fun key =>
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
OCaml.Stdlib.ignore
(Re.Str.search_forward re key 0) in
true) in
let fix loop (attempts : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let '(public_key_hash, public_key, secret_key) :=
Signature.generate_key None None tt in
let hash :=
apply Signature.Public_key_hash.to_b58check
(Signature.Public_key.hash public_key) in
if matches hash then
let pk_uri :=
Tezos_signer_backends.Unencrypted.make_pk
public_key in
op_gtgteqquestion
(if encrypted then
Tezos_signer_backends.Encrypted.encrypt cctxt
secret_key
else
_return
(Tezos_signer_backends.Unencrypted.make_sk
secret_key))
(fun sk_uri =>
op_gtgteqquestion
(register_key cctxt (Some force)
(public_key_hash, pk_uri, sk_uri) None
name)
(fun function_parameter =>
let 'tt := function_parameter in
_return hash))
else
op_gtgteq
(if equiv_decb (Z.modulo attempts 25000) 0 then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Tried " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" keys without finding a match" %
string
CamlinternalFormatBasics.End_of_format)))
"Tried %d keys without finding a match" %
string) attempts
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
loop (Z.add attempts 1))) in
op_gtgteqquestion (loop 1)
(fun key_hash =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Generated '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"' under the name '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"'." % string
CamlinternalFormatBasics.End_of_format)))))
"Generated '%s' under the name '%s'." %
string) key_hash name)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
end
end.
Fixpoint input_fundraiser_params {C a b : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) * C)))))))))))) * C)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Secret_key.t) :=
let fix get_boolean_answer {D : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) * D)))))))))))) * D) (default : bool)
(msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
let prompt :=
if default then
"(Y/n/q)" % string
else
"(y/N/q)" % string in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
CamlinternalFormatBasics.End_of_format)))) "%s %s: " % string)
msg prompt)
(fun gen =>
match (default, (String.lowercase_ascii gen)) with
| (default, "" % string) => _return default
| (_, "y" % string) => return_true
| (_, "n" % string) => return_false
| (_, "q" % string) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Exit by user request." % string
CamlinternalFormatBasics.End_of_format)
"Exit by user request." % string)
| _ => get_boolean_answer cctxt default msg
end) in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter the e-mail used for the paper wallet: " % string
CamlinternalFormatBasics.End_of_format)
"Enter the e-mail used for the paper wallet: " % string))
(fun email =>
let fix loop_words (acc : list Z) (i : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult (list Z)) :=
if OCaml.Stdlib.gt i 14 then
_return (List.rev acc)
else
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Enter word " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ": " % string
CamlinternalFormatBasics.End_of_format)))
"Enter word %d: " % string) i)
(fun word =>
match Bip39.index_of_word (Bigstring.to_string word) with
| None => loop_words acc i
| Some wordidx => loop_words (cons wordidx acc) (Z.succ i)
end) in
op_gtgteqquestion (loop_words [] 0)
(fun words =>
match Bip39.of_indices words with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some t =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter the password used for the paper wallet: " % string
CamlinternalFormatBasics.End_of_format)
"Enter the password used for the paper wallet: " % string))
(fun password =>
let passphrase :=
concat "" % string (cons (of_string email) (cons password []))
in
let sk := Bip39.to_seed (Some passphrase) t in
let sk := Bigstring.sub_bytes sk 0 32 in
let sk :=
Tezos_crypto__Signature.Ed25519
(Data_encoding.Binary.of_bytes_exn
Ed25519.Secret_key.encoding sk) in
let pk := Signature.Secret_key.to_public_key sk in
let pkh := Signature.Public_key.hash pk in
let msg :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Your public Tezos address is " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is that correct?" % string
CamlinternalFormatBasics.End_of_format)))
"Your public Tezos address is %a is that correct?" %
string) Signature.Public_key_hash.pp pkh in
op_gtgteqquestion (get_boolean_answer cctxt true msg)
(fun function_parameter =>
match function_parameter with
| true => _return sk
| false => input_fundraiser_params cctxt
end))
end)).
Definition commands (version : option variant)
: list
(Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
let encrypted_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
if
List._exists
(fun function_parameter =>
let '(scheme, _) := function_parameter in
equiv_decb scheme Tezos_signer_backends.Unencrypted.scheme)
(Client_keys.registered_signers tt) then
Clic.switch "Encrypt the key on-disk" % string None "encrypted" % string
tt
else
Clic.constant true in
let show_private_switch :=
switch "show the private key" % string (Some "S" % char)
"show-secret" % string tt in
OCaml.Stdlib.app
(cons
(command (Some group)
"List supported signing schemes.
Signing schemes are identifiers for signer modules: the built-in signing routines, a hardware wallet, an external agent, etc.
Each signer has its own format for describing secret keys, such a raw secret key for the default `unencrypted` scheme, the path on a hardware security module, an alias for an external agent, etc.
This command gives the list of signer modules that this version of the tezos client supports."
% string no_options
(fixed
(cons "list" % string
(cons "signing" % string (cons "schemes" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
let signers :=
List.sort
(fun function_parameter =>
let '(ka, _) := function_parameter in
fun function_parameter =>
let '(kb, _) := function_parameter in
String.compare ka kb) (registered_signers tt) in
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(n, _ as S) := function_parameter in
let S := projT2 S in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Scheme `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"`: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 0>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 2>Scheme `%s`: %s@,@[<hov 0>%a@]@]" % string) n
S.(Tezos_client_base.Client_keys.SIGNER.title)
Format.pp_print_text
S.(Tezos_client_base.Client_keys.SIGNER.description))
signers) _return))
(cons
match version with
| Some Mainnet =>
command (Some group) "Generate a pair of keys." % string
(args2 (Secret_key.force_switch tt) sig_algo_arg)
(apply (prefixes (cons "gen" % string (cons "keys" % string [])))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let '(force, algo) := function_parameter in
fun name =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
let '(pkh, pk, sk) :=
Signature.generate_key (Some algo) None tt in
let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk
in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.encrypt cctxt sk)
(fun sk_uri =>
register_key cctxt (Some force) (pkh, pk_uri, sk_uri)
None name)))
| _ =>
command (Some group) "Generate a pair of keys." % string
(args3 (Secret_key.force_switch tt) sig_algo_arg
(encrypted_switch tt))
(apply (prefixes (cons "gen" % string (cons "keys" % string [])))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let '(force, algo, encrypted) := function_parameter in
fun name =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
let '(pkh, pk, sk) :=
Signature.generate_key (Some algo) None tt in
let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk
in
op_gtgteqquestion
(if encrypted then
Tezos_signer_backends.Encrypted.encrypt cctxt sk
else
_return (Tezos_signer_backends.Unencrypted.make_sk sk))
(fun sk_uri =>
register_key cctxt (Some force) (pkh, pk_uri, sk_uri)
None name)))
end
(cons
match version with
| Some Mainnet =>
command (Some group)
"Generate keys including the given string." % string
(args2
(switch "the key must begin with tz1[word]" % string
(Some "P" % char) "prefix" % string tt) (force_switch tt))
(apply
(prefixes
(cons "gen" % string
(cons "vanity" % string (cons "keys" % string []))))
(apply
(let arg := Public_key_hash.fresh_alias_param in
fun eta => arg None None eta)
(apply (prefix "matching" % string)
(apply seq_of_param
(string "words" % string
"string key must contain one of these words" % string)))))
(fun function_parameter =>
let '(prefix, force) := function_parameter in
fun name =>
fun containing =>
fun cctxt =>
op_gtgteqquestion
(Public_key_hash.of_fresh cctxt force name)
(fun name =>
gen_keys_containing (Some true) (Some prefix)
(Some force) containing name cctxt))
| _ =>
command (Some group)
"Generate keys including the given string." % string
(args3
(switch "the key must begin with tz1[word]" % string
(Some "P" % char) "prefix" % string tt) (force_switch tt)
(encrypted_switch tt))
(apply
(prefixes
(cons "gen" % string
(cons "vanity" % string (cons "keys" % string []))))
(apply
(let arg := Public_key_hash.fresh_alias_param in
fun eta => arg None None eta)
(apply (prefix "matching" % string)
(apply seq_of_param
(string "words" % string
"string key must contain one of these words" % string)))))
(fun function_parameter =>
let '(prefix, force, encrypted) := function_parameter in
fun name =>
fun containing =>
fun cctxt =>
op_gtgteqquestion
(Public_key_hash.of_fresh cctxt force name)
(fun name =>
gen_keys_containing (Some encrypted) (Some prefix)
(Some force) containing name cctxt))
end
(cons
(command (Some group) "Encrypt an unencrypted secret key." % string
no_options
(apply
(prefixes
(cons "encrypt" % string
(cons "secret" % string (cons "key" % string [])))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter unencrypted secret key: " % string
CamlinternalFormatBasics.End_of_format)
"Enter unencrypted secret key: " % string))
(fun sk_uri =>
let sk_uri := Uri.of_string (Bigstring.to_string sk_uri)
in
op_gtgteqquestion
match Uri.scheme sk_uri with
| None | Some "unencrypted" % string => return_unit
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This command can only be used with the ""unencrypted"" scheme"
% string
CamlinternalFormatBasics.End_of_format)
"This command can only be used with the ""unencrypted"" scheme"
% string)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return
(Signature.Secret_key.of_b58check
(Uri.path sk_uri)))
(fun sk =>
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.encrypt cctxt
sk)
(fun sk_uri =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Encrypted secret key " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Encrypted secret key %a" % string)
Uri.pp_hum sk_uri)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))))
(cons
(command (Some group) "Add a secret key to the wallet." % string
(args1 (Secret_key.force_switch tt))
(apply (prefix "import" % string)
(apply
(prefixes (cons "secret" % string (cons "key" % string [])))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta)
(apply
(let arg := Client_keys.sk_uri_param in
fun eta => arg None None eta) stop))))
(fun force =>
fun name =>
fun sk_uri =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
op_gtgteqquestion (Client_keys.neuterize sk_uri)
(fun pk_uri =>
op_gtgteqquestion
(op_gtgteqquestion
(Public_key.find_opt cctxt name)
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (pk_uri_found, _) =>
fail_unless
(orb (equiv_decb pk_uri pk_uri_found)
force)
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"public and secret keys '" %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"' don't correspond, please don't use --force"
% string
CamlinternalFormatBasics.End_of_format)))
"public and secret keys '%s' don't correspond, please don't use --force"
% string) name)
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_keys.import_secret_key cctxt
pk_uri)
(fun function_parameter =>
let '(pkh, public_key) :=
function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Tezos address added: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Tezos address added: %a" % string)
Signature.Public_key_hash.pp pkh)
(fun function_parameter =>
let 'tt := function_parameter in
register_key cctxt (Some force)
(pkh, pk_uri, sk_uri) public_key
name))))))) [])))))
(OCaml.Stdlib.app
(if
nequiv_decb version
(Some
(* ❌ Variants not supported *)
variant) then
[]
else
cons
(command (Some group)
"Add a fundraiser secret key to the wallet." % string
(args1 (Secret_key.force_switch tt))
(apply (prefix "import" % string)
(apply
(prefixes
(cons "fundraiser" % string
(cons "secret" % string (cons "key" % string []))))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta) stop)))
(fun force =>
fun name =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
op_gtgteqquestion (input_fundraiser_params cctxt)
(fun sk =>
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.encrypt cctxt sk)
(fun sk_uri =>
op_gtgteqquestion (Client_keys.neuterize sk_uri)
(fun pk_uri =>
op_gtgteqquestion
(op_gtgteqquestion
(Public_key.find_opt cctxt name)
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (pk_uri_found, _) =>
fail_unless
(orb
(equiv_decb pk_uri pk_uri_found)
force)
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"public and secret keys '" %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"' don't correspond, please don't use --force"
% string
CamlinternalFormatBasics.End_of_format)))
"public and secret keys '%s' don't correspond, please don't use --force"
% string) name)
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_keys.public_key_hash pk_uri)
(fun function_parameter =>
let '(pkh, _public_key) :=
function_parameter in
register_key cctxt (Some force)
(pkh, pk_uri, sk_uri) None name))))))))
[])
(cons
(command (Some group) "Add a public key to the wallet." % string
(args1 (Public_key.force_switch tt))
(apply (prefix "import" % string)
(apply (prefixes (cons "public" % string (cons "key" % string [])))
(apply
(let arg := Public_key.fresh_alias_param in
fun eta => arg None None eta)
(apply
(let arg := Client_keys.pk_uri_param in
fun eta => arg None None eta) stop))))
(fun force =>
fun name =>
fun pk_uri =>
fun cctxt =>
op_gtgteqquestion (Public_key.of_fresh cctxt force name)
(fun name =>
op_gtgteqquestion (Client_keys.public_key_hash pk_uri)
(fun function_parameter =>
let '(pkh, public_key) := function_parameter in
op_gtgteqquestion
(Public_key_hash.add force cctxt name pkh)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Tezos address added: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Tezos address added: %a" % string)
Signature.Public_key_hash.pp pkh)
(fun function_parameter =>
let 'tt := function_parameter in
Public_key.add force cctxt name
(pk_uri, public_key)))))))
(cons
(command (Some group) "Add an address to the wallet." % string
(args1 (Public_key.force_switch tt))
(apply (prefixes (cons "add" % string (cons "address" % string [])))
(apply
(let arg := Public_key_hash.fresh_alias_param in
fun eta => arg None None eta)
(apply
(let arg := Public_key_hash.source_param in
fun eta => arg None None eta) stop)))
(fun force =>
fun name =>
fun hash =>
fun cctxt =>
op_gtgteqquestion
(Public_key_hash.of_fresh cctxt force name)
(fun name => Public_key_hash.add force cctxt name hash)))
(cons
(command (Some group)
"List all addresses and associated keys." % string no_options
(fixed
(cons "list" % string
(cons "known" % string (cons "addresses" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (list_keys cctxt)
(fun l =>
iter_s
(fun function_parameter =>
let '(name, pkh, pk, sk) := function_parameter in
op_gtgteqquestion (Public_key_hash.to_source pkh)
(fun v =>
op_gtgteq
match (pk, sk) with
| (None, None) =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"%s: %s" % string) name v
| (_, Some uri) =>
let scheme :=
apply (Option.unopt "unencrypted" % string)
(Uri.scheme uri) in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" sk known)" % string
CamlinternalFormatBasics.End_of_format))))))
"%s: %s (%s sk known)" % string) name v
scheme
| (Some _, _) =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (pk known)" % string
CamlinternalFormatBasics.End_of_format))))
"%s: %s (pk known)" % string) name v
end
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) l)))
(cons
(command (Some group)
"Show the keys associated with an implicit account." % string
(args1 show_private_switch)
(apply
(prefixes (cons "show" % string (cons "address" % string [])))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta) stop))
(fun show_private =>
fun function_parameter =>
let '(name, _) := function_parameter in
fun cctxt =>
op_gtgteqquestion (alias_keys cctxt name)
(fun key_info =>
match key_info with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No keys found for address" % string
CamlinternalFormatBasics.End_of_format)
"No keys found for address" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some (pkh, pk, skloc) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Hash: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Hash: %a" % string)
Signature.Public_key_hash.pp pkh)
(fun function_parameter =>
let 'tt := function_parameter in
match pk with
| None => return_unit
| Some pk =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Public Key: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Public Key: %a" % string)
Signature.Public_key.pp pk)
(fun function_parameter =>
let 'tt := function_parameter in
if show_private then
match skloc with
| None => return_unit
| Some skloc =>
op_gtgteqquestion
(Secret_key.to_source skloc)
(fun skloc =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Secret Key: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Secret Key: %s" % string)
skloc)
(fun function_parameter =>
let 'tt := function_parameter
in
return_unit))
end
else
return_unit)
end)
end)))
(cons
(command (Some group) "Forget one address." % string
(args1
(Clic.switch "delete associated keys when present" % string
(Some "f" % char) "force" % string tt))
(apply
(prefixes
(cons "forget" % string (cons "address" % string [])))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta) stop))
(fun force =>
fun function_parameter =>
let '(name, _pkh) := function_parameter in
fun cctxt =>
op_gtgteqquestion (Secret_key.mem cctxt name)
(fun has_secret_key =>
op_gtgteqquestion (Public_key.mem cctxt name)
(fun has_public_key =>
op_gtgteqquestion
(fail_when
(andb (negb force)
(orb has_secret_key has_public_key))
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"secret or public key present for " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
", use --force to delete" % string
CamlinternalFormatBasics.End_of_format)))
"secret or public key present for %s, use --force to delete"
% string) name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Secret_key.del cctxt name)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Public_key.del cctxt name)
(fun function_parameter =>
let 'tt := function_parameter in
Public_key_hash.del cctxt name)))))))
(cons
(command (Some group)
"Forget the entire wallet of keys." % string
(args1
(Clic.switch "you got to use the force for that" % string
(Some "f" % char) "force" % string tt))
(fixed
(cons "forget" % string
(cons "all" % string (cons "keys" % string []))))
(fun force =>
fun cctxt =>
op_gtgteqquestion
(fail_unless force
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"this can only be used with option --force" %
string
CamlinternalFormatBasics.End_of_format)
"this can only be used with option --force" %
string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Public_key.set cctxt [])
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Secret_key.set cctxt [])
(fun function_parameter =>
let 'tt := function_parameter in
Public_key_hash.set cctxt [])))))
(cons
(command (Some group)
"Compute deterministic nonce." % string no_options
(apply
(prefixes
(cons "generate" % string
(cons "nonce" % string (cons "for" % string []))))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta)
(apply (prefixes (cons "from" % string []))
(apply
(string "data" % string
"string from which to deterministically generate the nonce"
% string) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(name, _pkh) := function_parameter in
fun data =>
fun cctxt =>
let data := Stdlib.Bytes.of_string data in
op_gtgteqquestion (Secret_key.mem cctxt name)
(fun sk_present =>
op_gtgteqquestion
(fail_unless sk_present
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"secret key not present for " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"secret key not present for %s" %
string) name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Secret_key.find cctxt name)
(fun sk_uri =>
op_gtgteqquestion
(Client_keys.deterministic_nonce
sk_uri data)
(fun nonce =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Hex.pp
(Hex.of_bytes None
(Bigstring.to_bytes nonce)))
(fun function_parameter =>
let 'tt := function_parameter
in
return_unit)))))))
(cons
(command (Some group)
"Compute deterministic nonce hash." % string no_options
(apply
(prefixes
(cons "generate" % string
(cons "nonce" % string
(cons "hash" % string (cons "for" % string [])))))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta)
(apply (prefixes (cons "from" % string []))
(apply
(string "data" % string
"string from which to deterministically generate the nonce hash"
% string) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(name, _pkh) := function_parameter in
fun data =>
fun cctxt =>
let data := Stdlib.Bytes.of_string data in
op_gtgteqquestion (Secret_key.mem cctxt name)
(fun sk_present =>
op_gtgteqquestion
(fail_unless sk_present
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"secret key not present for " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"secret key not present for %s" %
string) name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Secret_key.find cctxt name)
(fun sk_uri =>
op_gtgteqquestion
(Client_keys.deterministic_nonce_hash
sk_uri data)
(fun nonce_hash =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Hex.pp
(Hex.of_bytes None
nonce_hash))
(fun function_parameter =>
let 'tt :=
function_parameter in
return_unit))))))) []))))))))).
src/lib_client_commands/client_p2p_commands.ml 235 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let group =
{
Clic.name = "p2p";
title = "Commands for monitoring and controlling p2p-layer state";
}
let pp_connection_info ppf conn =
P2p_connection.Info.pp (fun _ _ -> ()) ppf conn
let addr_parameter =
let open Clic in
param
~name:"address"
~desc:"<IPv4>:PORT or <IPV6>:PORT address (PORT defaults to 9732)."
(parameter (fun _ x ->
return (P2p_point.Id.of_string_exn ~default_port:9732 x)))
let p2p_peer_id_param ~name ~desc t =
Clic.param
~name
~desc
(Clic.parameter (fun _ str -> Lwt.return (P2p_peer.Id.of_b58check str)))
t
let commands () =
let open Clic in
[ command
~group
~desc:"show global network status"
no_options
(prefixes ["p2p"; "stat"] stop)
(fun () (cctxt : #Client_context.full) ->
Shell_services.P2p.stat cctxt
>>=? fun stat ->
Shell_services.P2p.Connections.list cctxt
>>=? fun conns ->
Shell_services.P2p.Peers.list cctxt
>>=? fun peers ->
Shell_services.P2p.Points.list cctxt
>>=? fun points ->
cctxt#message "GLOBAL STATS"
>>= fun () ->
cctxt#message " %a" P2p_stat.pp stat
>>= fun () ->
cctxt#message "CONNECTIONS"
>>= fun () ->
let (incoming, outgoing) =
List.partition (fun c -> c.P2p_connection.Info.incoming) conns
in
Lwt_list.iter_s
(fun conn -> cctxt#message " %a" pp_connection_info conn)
incoming
>>= fun () ->
Lwt_list.iter_s
(fun conn -> cctxt#message " %a" pp_connection_info conn)
outgoing
>>= fun () ->
cctxt#message "KNOWN PEERS"
>>= fun () ->
Lwt_list.iter_s
(fun (p, pi) ->
cctxt#message
" %a %.0f %a %a %s"
P2p_peer.State.pp_digram
pi.P2p_peer.Info.state
pi.score
P2p_peer.Id.pp
p
P2p_stat.pp
pi.stat
(if pi.trusted then "â
" else " "))
peers
>>= fun () ->
cctxt#message "KNOWN POINTS"
>>= fun () ->
Lwt_list.iter_s
(fun (p, pi) ->
match pi.P2p_point.Info.state with
| Running peer_id ->
cctxt#message
" %a %a %a %s"
P2p_point.State.pp_digram
pi.state
P2p_point.Id.pp
p
P2p_peer.Id.pp
peer_id
(if pi.trusted then "â
" else " ")
| _ -> (
match pi.last_seen with
| Some (peer_id, ts) ->
cctxt#message
" %a %a (last seen: %a %a) %s"
P2p_point.State.pp_digram
pi.state
P2p_point.Id.pp
p
P2p_peer.Id.pp
peer_id
Time.System.pp_hum
ts
(if pi.trusted then "â
" else " ")
| None ->
cctxt#message
" %a %a %s"
P2p_point.State.pp_digram
pi.state
P2p_point.Id.pp
p
(if pi.trusted then "â
" else " ") ))
points
>>= fun () -> return_unit);
command
~group
~desc:"Connect to a new point."
no_options
(prefixes ["connect"; "address"] @@ addr_parameter @@ stop)
(fun () (address, port) (cctxt : #Client_context.full) ->
let timeout = Time.System.Span.of_seconds_exn 10. in
P2p_services.connect cctxt ~timeout (address, port)
>>= function
| Ok () ->
cctxt#message
"Connection to %a:%d established."
P2p_addr.pp
address
port
>>= fun () -> return_unit
| Error (Tezos_p2p.P2p_errors.Pending_connection :: _) ->
cctxt#warning "Already connecting to peer %a" P2p_addr.pp address
>>= fun () -> return_unit
| Error (Tezos_p2p.P2p_errors.Connected :: _) ->
cctxt#warning "Already connected to peer %a" P2p_addr.pp address
>>= fun () -> return_unit
| Error _ as e ->
Lwt.return e);
command
~group
~desc:"Kick a peer."
no_options
( prefixes ["kick"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Connections.kick cctxt peer
>>=? fun () ->
cctxt#message "Connection to %a interrupted." P2p_peer.Id.pp peer
>>= fun () -> return_unit);
command
~group
~desc:
"Add an IP address and all its ports to the blacklist and kicks it. \
Remove the address from the whitelist if it was previously in it."
no_options
(prefixes ["ban"; "address"] @@ addr_parameter @@ stop)
(fun () (address, _port) (cctxt : #Client_context.full) ->
P2p_services.Points.ban cctxt (address, 0)
>>=? fun () ->
cctxt#message "Address %a:* is now banned." P2p_addr.pp address
>>= fun () -> return_unit);
command
~group
~desc:"Remove an IP address and all its ports from the blacklist."
no_options
(prefixes ["unban"; "address"] @@ addr_parameter @@ stop)
(fun () (address, _port) (cctxt : #Client_context.full) ->
P2p_services.Points.unban cctxt (address, 0)
>>=? fun () ->
cctxt#message "Address %a:* is now unbanned." P2p_addr.pp address
>>= fun () -> return_unit);
command
~group
~desc:
"Add an IP address to the whitelist. Remove the address from the \
blacklist if it was previously in it."
no_options
(prefixes ["trust"; "address"] @@ addr_parameter @@ stop)
(fun () (address, port) (cctxt : #Client_context.full) ->
P2p_services.Points.trust cctxt (address, port)
>>=? fun () ->
cctxt#message "Address %a:%d is now trusted." P2p_addr.pp address port
>>= fun () -> return_unit);
command
~group
~desc:"Removes an IP address from the whitelist."
no_options
(prefixes ["untrust"; "address"] @@ addr_parameter @@ stop)
(fun () (address, port) (cctxt : #Client_context.full) ->
P2p_services.Points.untrust cctxt (address, port)
>>=? fun () ->
cctxt#message
"Address %a:%d is now untrusted."
P2p_addr.pp
address
port
>>= fun () -> return_unit);
command
~group
~desc:"Check if an IP address is banned."
no_options
(prefixes ["is"; "address"; "banned"] @@ addr_parameter @@ stop)
(fun () (address, port) (cctxt : #Client_context.full) ->
P2p_services.Points.banned cctxt (address, port)
>>=? fun banned ->
cctxt#message
"The given ip address is %s"
(if banned then "banned" else "not banned")
>>= fun () -> return_unit);
command
~group
~desc:"Check if a peer ID is banned."
no_options
( prefixes ["is"; "peer"; "banned"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.banned cctxt peer
>>=? fun banned ->
cctxt#message
"The given peer ID is %s"
(if banned then "banned" else "not banned")
>>= fun () -> return_unit);
command
~group
~desc:
"Add a peer ID to the blacklist and kicks it. Remove the peer ID from \
the blacklist if was previously in it."
no_options
( prefixes ["ban"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.ban cctxt peer
>>=? fun () ->
cctxt#message "The peer %a is now banned." P2p_peer.Id.pp_short peer
>>= fun () -> return_unit);
command
~group
~desc:"Removes a peer ID from the blacklist."
no_options
( prefixes ["unban"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.unban cctxt peer
>>=? fun () ->
cctxt#message "The peer %a is now unbanned." P2p_peer.Id.pp_short peer
>>= fun () -> return_unit);
command
~group
~desc:
"Add a peer ID to the whitelist. Remove the peer ID from the \
blacklist if it was previously in it."
no_options
( prefixes ["trust"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.trust cctxt peer
>>=? fun () ->
cctxt#message "The peer %a is now trusted." P2p_peer.Id.pp_short peer
>>= fun () -> return_unit);
command
~group
~desc:"Remove a peer ID from the whitelist."
no_options
( prefixes ["untrust"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.untrust cctxt peer
>>=? fun () ->
cctxt#message "The peer %a is now untrusted." P2p_peer.Id.pp_short peer
>>= fun () -> return_unit);
command
~group
~desc:"Clear all access control rules."
no_options
(prefixes ["clear"; "acls"] @@ stop)
(fun () (cctxt : #Client_context.full) ->
P2p_services.ACL.clear cctxt ()
>>=? fun () ->
cctxt#message "The access control rules are now cleared."
>>= fun () -> return_unit) ]
src/lib_client_commands/client_p2p_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "p2p" % string;
Clic.title :=
"Commands for monitoring and controlling p2p-layer state" % string |}.
Definition pp_connection_info {A : Type}
(ppf : Stdlib.Format.formatter)
(conn : Tezos_base__TzPervasives.P2p_connection.Info.t A) : unit :=
P2p_connection.Info.pp
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
tt) ppf conn.
Definition addr_parameter {F G I a b i o p q : Type}
: (Tezos_base__TzPervasives.Clic.params
((((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) ->
Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.P2p_point.Id.t ->
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
param "address" % string
"<IPv4>:PORT or <IPV6>:PORT address (PORT defaults to 9732)." % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => _return (P2p_point.Id.of_string_exn (Some 9732) x))).
Definition p2p_peer_id_param {A B : Type}
(name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.P2p_peer.Id.t -> A) B :=
Clic.param name desc
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun str => Lwt._return (P2p_peer.Id.of_b58check str))) t.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
cons
(command (Some group) "show global network status" % string no_options
(prefixes (cons "p2p" % string (cons "stat" % string [])) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Shell_services.P2p.stat cctxt)
(fun stat =>
op_gtgteqquestion (Shell_services.P2p.Connections.list cctxt)
(fun conns =>
op_gtgteqquestion (Shell_services.P2p.Peers.list None cctxt)
(fun peers =>
op_gtgteqquestion
(Shell_services.P2p.Points.list None cctxt)
(fun points =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"GLOBAL STATS" % string
CamlinternalFormatBasics.End_of_format)
"GLOBAL STATS" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" %a" % string) P2p_stat.pp stat)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"CONNECTIONS" % string
CamlinternalFormatBasics.End_of_format)
"CONNECTIONS" % string))
(fun function_parameter =>
let 'tt := function_parameter in
let '(incoming, outgoing) :=
List.partition
(fun c =>
P2p_connection.Info.incoming c)
conns in
op_gtgteq
(Lwt_list.iter_s
(fun conn =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" %a" % string)
pp_connection_info conn) incoming)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_list.iter_s
(fun conn =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" %a" % string)
pp_connection_info conn)
outgoing)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"KNOWN PEERS" % string
CamlinternalFormatBasics.End_of_format)
"KNOWN PEERS" % string))
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(p, pi) :=
function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision
0)
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" " %
char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))))))
" %a %.0f %a %a %s"
% string)
P2p_peer.State.pp_digram
(P2p_peer.Info.state
pi) (score pi)
P2p_peer.Id.pp p
P2p_stat.pp (stat pi)
(if trusted pi then
"★" % string
else
" " % string)) peers)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"KNOWN POINTS" %
string
CamlinternalFormatBasics.End_of_format)
"KNOWN POINTS" %
string))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(Lwt_list.iter_s
(fun
function_parameter
=>
let '(p, pi) :=
function_parameter
in
match
P2p_point.Info.state
pi with
|
Tezos_base__P2p_point.State.Running
peer_id =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))))
" %a %a %a %s"
% string)
P2p_point.State.pp_digram
(state pi)
P2p_point.Id.pp
p
P2p_peer.Id.pp
peer_id
(if
trusted pi
then
"★" %
string
else
" " %
string)
| _ =>
match
last_seen pi
with
|
Some
(peer_id,
ts) =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (last seen: "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") "
%
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))))))
" %a %a (last seen: %a %a) %s"
%
string)
P2p_point.State.pp_digram
(state pi)
P2p_point.Id.pp
p
P2p_peer.Id.pp
peer_id
Time.System.pp_hum
ts
(if
trusted
pi
then
"★" %
string
else
" " %
string)
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))
" %a %a %s"
%
string)
P2p_point.State.pp_digram
(state pi)
P2p_point.Id.pp
p
(if
trusted
pi
then
"★" %
string
else
" " %
string)
end
end) points)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
return_unit)))))))))))))))
(cons
(command (Some group) "Connect to a new point." % string no_options
(apply (prefixes (cons "connect" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, port) := function_parameter in
fun cctxt =>
let timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 10. is approximated by the integer 10 *)
10 in
op_gtgteq (P2p_services.connect cctxt timeout (address, port))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Connection to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" established." % string
CamlinternalFormatBasics.End_of_format)))))
"Connection to %a:%d established." % string)
P2p_addr.pp address port)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
|
Stdlib.Error
(cons Tezos_base__TzPervasives.Pending_connection _) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Already connecting to peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Already connecting to peer %a" % string) P2p_addr.pp
address)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error (cons Tezos_base__TzPervasives.Connected _) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Already connected to peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Already connected to peer %a" % string) P2p_addr.pp
address)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| (Stdlib.Error _) as e => Lwt._return e
end)))
(cons
(command (Some group) "Kick a peer." % string no_options
(apply (prefixes (cons "kick" % string (cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Connections.kick cctxt None peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Connection to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" interrupted." % string
CamlinternalFormatBasics.End_of_format)))
"Connection to %a interrupted." % string)
P2p_peer.Id.pp peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Add an IP address and all its ports to the blacklist and kicks it. Remove the address from the whitelist if it was previously in it."
% string no_options
(apply (prefixes (cons "ban" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, _port) := function_parameter in
fun cctxt =>
op_gtgteqquestion (P2p_services.Points.ban cctxt (address, 0))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Address " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
":* is now banned." % string
CamlinternalFormatBasics.End_of_format)))
"Address %a:* is now banned." % string) P2p_addr.pp
address)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Remove an IP address and all its ports from the blacklist." %
string no_options
(apply
(prefixes (cons "unban" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, _port) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.Points.unban cctxt (address, 0))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Address " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
":* is now unbanned." % string
CamlinternalFormatBasics.End_of_format)))
"Address %a:* is now unbanned." % string)
P2p_addr.pp address)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Add an IP address to the whitelist. Remove the address from the blacklist if it was previously in it."
% string no_options
(apply
(prefixes (cons "trust" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, port) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.Points.trust cctxt (address, port))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Address " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
":" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" is now trusted." % string
CamlinternalFormatBasics.End_of_format)))))
"Address %a:%d is now trusted." % string)
P2p_addr.pp address port)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Removes an IP address from the whitelist." % string
no_options
(apply
(prefixes
(cons "untrust" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, port) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.Points.untrust cctxt (address, port))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Address " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
":" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" is now untrusted." % string
CamlinternalFormatBasics.End_of_format)))))
"Address %a:%d is now untrusted." % string)
P2p_addr.pp address port)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Check if an IP address is banned." % string no_options
(apply
(prefixes
(cons "is" % string
(cons "address" % string (cons "banned" % string []))))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, port) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.Points.banned cctxt (address, port))
(fun banned =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The given ip address is " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"The given ip address is %s" % string)
(if banned then
"banned" % string
else
"not banned" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Check if a peer ID is banned." % string no_options
(apply
(prefixes
(cons "is" % string
(cons "peer" % string (cons "banned" % string []))))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.banned cctxt peer)
(fun banned =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The given peer ID is " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"The given peer ID is %s" % string)
(if banned then
"banned" % string
else
"not banned" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Add a peer ID to the blacklist and kicks it. Remove the peer ID from the blacklist if was previously in it."
% string no_options
(apply
(prefixes
(cons "ban" % string (cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.ban cctxt peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is now banned." % string
CamlinternalFormatBasics.End_of_format)))
"The peer %a is now banned." % string)
P2p_peer.Id.pp_short peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Removes a peer ID from the blacklist." % string
no_options
(apply
(prefixes
(cons "unban" % string (cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.unban cctxt peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is now unbanned." % string
CamlinternalFormatBasics.End_of_format)))
"The peer %a is now unbanned." %
string) P2p_peer.Id.pp_short peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Add a peer ID to the whitelist. Remove the peer ID from the blacklist if it was previously in it."
% string no_options
(apply
(prefixes
(cons "trust" % string (cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.trust cctxt peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is now trusted." % string
CamlinternalFormatBasics.End_of_format)))
"The peer %a is now trusted." %
string) P2p_peer.Id.pp_short peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Remove a peer ID from the whitelist." % string
no_options
(apply
(prefixes
(cons "untrust" % string
(cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.untrust cctxt peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is now untrusted." %
string
CamlinternalFormatBasics.End_of_format)))
"The peer %a is now untrusted." %
string) P2p_peer.Id.pp_short
peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Clear all access control rules." % string
no_options
(apply
(prefixes
(cons "clear" % string
(cons "acls" % string []))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.ACL.clear cctxt tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The access control rules are now cleared."
% string
CamlinternalFormatBasics.End_of_format)
"The access control rules are now cleared."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))) []))))))))))))).
src/lib_client_commands/client_report_commands.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Commands used to introspect the node's state *)
let print_invalid_blocks ppf (b : Shell_services.Chain.invalid_block) =
Format.fprintf
ppf
"@[<v 2>Hash: %a@ Level: %ld@ %a@]"
Block_hash.pp
b.hash
b.level
pp_print_error
b.errors
let commands () =
let open Clic in
let group =
{name = "report"; title = "Commands to report the node's status"}
in
let output_arg =
default_arg
~doc:"write to a file"
~long:"output"
~short:'o'
~placeholder:"path"
~default:"-"
(parameter (fun _ ->
function
| "-" ->
return Format.std_formatter
| file ->
let ppf = Format.formatter_of_out_channel (open_out file) in
ignore Clic.(setup_formatter ppf Plain Full) ;
return ppf))
in
[ command
~group
~desc:"The last heads that have been considered by the node."
(args1 output_arg)
(fixed ["list"; "heads"])
(fun ppf cctxt ->
Shell_services.Blocks.list cctxt ()
>>=? fun heads ->
Format.fprintf
ppf
"@[<v>%a@]@."
(Format.pp_print_list Block_hash.pp)
(List.concat heads) ;
return_unit);
command
~group
~desc:"The blocks that have been marked invalid by the node."
(args1 output_arg)
(fixed ["list"; "rejected"; "blocks"])
(fun ppf cctxt ->
Shell_services.Invalid_blocks.list cctxt ()
>>=? function
| [] ->
Format.fprintf ppf "No invalid blocks.@." ;
return_unit
| _ :: _ as invalid ->
Format.fprintf
ppf
"@[<v>%a@]@."
(Format.pp_print_list print_invalid_blocks)
invalid ;
return_unit) ]
src/lib_client_commands/client_report_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition print_invalid_blocks
(ppf : Stdlib.Format.formatter)
(b : Tezos_shell_services.Shell_services.Chain.invalid_block) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Hash: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "Level: " % string
(CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 2>Hash: %a@ Level: %ld@ %a@]" % string) Block_hash.pp (hash b)
(level b) pp_print_error (errors b).
Definition commands {E F i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)) :=
let 'tt := function_parameter in
let group :=
{| name := "report" % string;
title := "Commands to report the node's status" % string |} in
let output_arg :=
default_arg "write to a file" % string (Some "o" % char) "output" % string
"path" % string "-" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
match function_parameter with
| "-" % string => _return Format.std_formatter
| file =>
let ppf := Format.formatter_of_out_channel (Stdlib.open_out file)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter ppf Tezos_base__TzPervasives.Clic.Plain
Tezos_base__TzPervasives.Clic.Full) in
_return ppf
end)) in
cons
(command (Some group)
"The last heads that have been considered by the node." % string
(args1 output_arg)
(fixed (cons "list" % string (cons "heads" % string [])))
(fun ppf =>
fun cctxt =>
op_gtgteqquestion
(Shell_services.Blocks.list cctxt None None None None tt)
(fun heads =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"@[<v>%a@]@." % string)
(Format.pp_print_list None Block_hash.pp) (List.concat heads)
in
return_unit)))
(cons
(command (Some group)
"The blocks that have been marked invalid by the node." % string
(args1 output_arg)
(fixed
(cons "list" % string
(cons "rejected" % string (cons "blocks" % string []))))
(fun ppf =>
fun cctxt =>
op_gtgteqquestion (Shell_services.Invalid_blocks.list cctxt None tt)
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No invalid blocks." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"No invalid blocks.@." % string) in
return_unit
| (cons _ _) as invalid =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"@[<v>%a@]@." % string)
(Format.pp_print_list None print_invalid_blocks) invalid
in
return_unit
end))) []).
src/lib_crypto/blake2B.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
(*-- Type specific Hash builder ---------------------------------------------*)
module type Name = sig
val name : string
val title : string
val size : int option
end
module type PrefixedName = sig
include Name
val b58check_prefix : string
end
module Make_minimal (K : Name) = struct
open Blake2
type t = Blake2b.hash
include K
let size = match K.size with None -> 32 | Some x -> x
let of_string_opt s =
if String.length s <> size then None
else Some (Blake2b.Hash (Bytes.of_string s))
let of_string s =
match of_string_opt s with
| None ->
generic_error
"%s.of_string: wrong string size (%d)"
K.name
(String.length s)
| Some h ->
Ok h
let of_string_exn s =
match of_string_opt s with
| None ->
Format.kasprintf
invalid_arg
"%s.of_string: wrong string size (%d)"
K.name
(String.length s)
| Some h ->
h
let to_string (Blake2b.Hash h) = Bytes.to_string h
let of_hex s = of_string (Hex.to_string s)
let of_hex_opt s = of_string_opt (Hex.to_string s)
let of_hex_exn s = of_string_exn (Hex.to_string s)
let to_hex s = Hex.of_string (to_string s)
let pp ppf h =
let (`Hex h) = to_hex h in
Format.pp_print_string ppf h
let pp_short ppf h =
let (`Hex h) = to_hex h in
Format.pp_print_string ppf (String.sub h 0 8)
let of_bytes_opt b =
if Bytes.length b <> size then None else Some (Blake2b.Hash b)
let of_bytes_exn b =
match of_bytes_opt b with
| None ->
let msg =
Printf.sprintf
"%s.of_bytes: wrong string size (%d)"
K.name
(Bytes.length b)
in
raise (Invalid_argument msg)
| Some h ->
h
let of_bytes s =
match of_bytes_opt s with
| Some x ->
Ok x
| None ->
generic_error "Failed to deserialize a hash (%s)" K.name
let to_bytes (Blake2b.Hash h) = h
let hash_bytes ?key l =
let state = Blake2b.init ?key size in
List.iter (fun b -> Blake2b.update state b) l ;
Blake2b.final state
let hash_string ?key l =
let key = Option.map ~f:Bytes.of_string key in
let state = Blake2b.init ?key size in
List.iter (fun s -> Blake2b.update state (Bytes.of_string s)) l ;
Blake2b.final state
let path_length = 6
(** Converts [key] to hex thus doubling its size then splits it into a list of
length [path_length] where each element is one byte, or two characters,
except the last one which contains the rest. *)
let to_path key l =
let (`Hex key) = to_hex key in
String.sub key 0 2 :: String.sub key 2 2 :: String.sub key 4 2
:: String.sub key 6 2 :: String.sub key 8 2
:: String.sub key 10 ((size * 2) - 10)
:: l
let of_path path =
let path = String.concat "" path in
of_hex_opt (`Hex path)
let of_path_exn path =
let path = String.concat "" path in
of_hex_exn (`Hex path)
let prefix_path p =
let (`Hex p) = Hex.of_string p in
let len = String.length p in
let p1 = if len >= 2 then String.sub p 0 2 else ""
and p2 = if len >= 4 then String.sub p 2 2 else ""
and p3 = if len >= 6 then String.sub p 4 2 else ""
and p4 = if len >= 8 then String.sub p 6 2 else ""
and p5 = if len >= 10 then String.sub p 8 2 else ""
and p6 =
if len > 10 then String.sub p 10 (min (len - 10) ((size * 2) - 10))
else ""
in
[p1; p2; p3; p4; p5; p6]
let zero = of_hex_exn (`Hex (String.make (size * 2) '0'))
include Compare.Make (struct
type nonrec t = t
let compare (Blake2b.Hash h1) (Blake2b.Hash h2) = Bytes.compare h1 h2
end)
end
module Make (R : sig
val register_encoding :
prefix:string ->
length:int ->
to_raw:('a -> string) ->
of_raw:(string -> 'a option) ->
wrap:('a -> Base58.data) ->
'a Base58.encoding
end)
(K : PrefixedName) =
struct
include Make_minimal (K)
(* Serializers *)
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let hash =
if Compare.Int.(size >= 8) then fun h ->
Int64.to_int (TzEndian.get_int64 (to_bytes h) 0)
else if Compare.Int.(size >= 4) then fun h ->
Int32.to_int (TzEndian.get_int32 (to_bytes h) 0)
else fun h ->
let r = ref 0 in
let h = to_bytes h in
for i = 0 to size - 1 do
r := TzEndian.get_uint8 h i + (8 * !r)
done ;
!r
type Base58.data += Data of t
let b58check_encoding =
R.register_encoding
~prefix:K.b58check_prefix
~length:size
~wrap:(fun s -> Data s)
~of_raw:of_string_opt
~to_raw:to_string
include Helpers.Make (struct
type nonrec t = t
let title = title
let name = name
let b58check_encoding = b58check_encoding
let raw_encoding = raw_encoding
let compare = compare
let equal = equal
let hash = hash
end)
end
module Generic_Merkle_tree (H : sig
type t
type elt
val empty : t
val leaf : elt -> t
val node : t -> t -> t
end) =
struct
let rec step a n =
let m = (n + 1) / 2 in
for i = 0 to m - 1 do
a.(i) <- H.node a.(2 * i) a.((2 * i) + 1)
done ;
a.(m) <- H.node a.(n) a.(n) ;
if m = 1 then a.(0)
else if m mod 2 = 0 then step a m
else (
a.(m + 1) <- a.(m) ;
step a (m + 1) )
let empty = H.empty
let compute xs =
match xs with
| [] ->
H.empty
| [x] ->
H.leaf x
| _ :: _ :: _ ->
let last = TzList.last_exn xs in
let n = List.length xs in
let a = Array.make (n + 1) (H.leaf last) in
List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
step a n
type path = Left of path * H.t | Right of H.t * path | Op
let rec step_path a n p j =
let m = (n + 1) / 2 in
let p =
if j mod 2 = 0 then Left (p, a.(j + 1)) else Right (a.(j - 1), p)
in
for i = 0 to m - 1 do
a.(i) <- H.node a.(2 * i) a.((2 * i) + 1)
done ;
a.(m) <- H.node a.(n) a.(n) ;
if m = 1 then p
else if m mod 2 = 0 then step_path a m p (j / 2)
else (
a.(m + 1) <- a.(m) ;
step_path a (m + 1) p (j / 2) )
let compute_path xs i =
match xs with
| [] ->
invalid_arg "compute_path"
| [_] ->
Op
| _ :: _ :: _ ->
let last = TzList.last_exn xs in
let n = List.length xs in
if i < 0 || n <= i then invalid_arg "compute_path" ;
let a = Array.make (n + 1) (H.leaf last) in
List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
step_path a n Op i
let rec check_path p h =
match p with
| Op ->
(H.leaf h, 1, 0)
| Left (p, r) ->
let (l, s, pos) = check_path p h in
(H.node l r, s * 2, pos)
| Right (l, p) ->
let (r, s, pos) = check_path p h in
(H.node l r, s * 2, pos + s)
let check_path p h =
let (h, _, pos) = check_path p h in
(h, pos)
end
let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2)
module Make_merkle_tree (R : sig
val register_encoding :
prefix:string ->
length:int ->
to_raw:('a -> string) ->
of_raw:(string -> 'a option) ->
wrap:('a -> Base58.data) ->
'a Base58.encoding
end)
(K : PrefixedName) (Contents : sig
type t
val to_bytes : t -> Bytes.t
end) =
struct
include Make (R) (K)
type elt = Contents.t
let elt_bytes = Contents.to_bytes
let empty = hash_bytes []
include Generic_Merkle_tree (struct
type nonrec t = t
type nonrec elt = elt
let empty = empty
let leaf x = hash_bytes [Contents.to_bytes x]
let node x y = hash_bytes [to_bytes x; to_bytes y]
end)
let path_encoding =
let open Data_encoding in
mu "path" (fun path_encoding ->
union
[ case
(Tag 240)
~title:"Left"
(obj2 (req "path" path_encoding) (req "right" encoding))
(function Left (p, r) -> Some (p, r) | _ -> None)
(fun (p, r) -> Left (p, r));
case
(Tag 15)
~title:"Right"
(obj2 (req "left" encoding) (req "path" path_encoding))
(function Right (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Right (r, p));
case
(Tag 0)
~title:"Op"
unit
(function Op -> Some () | _ -> None)
(fun () -> Op) ])
let bounded_path_encoding ?max_length () =
match max_length with
| None ->
path_encoding
| Some max_length ->
let max_depth = log2 max_length in
Data_encoding.check_size ((max_depth * (size + 1)) + 1) path_encoding
end
include Make_minimal (struct
let name = "Generic_hash"
let title = ""
let size = None
end)
let pp ppf h =
let (`Hex h) = to_hex h in
Format.pp_print_string ppf h
let pp_short ppf h =
let (`Hex h) = to_hex h in
Format.pp_print_string ppf (String.sub h 0 8)
src/lib_crypto/blake2B.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module Name.
Record signature := {
name : string;
title : string;
size : option Z;
}.
End Name.
Module PrefixedName.
Record signature := {
include;
b58check_prefix : string;
}.
End PrefixedName.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
Fixpoint log2 (x : Z) : Z :=
if OCaml.Stdlib.le x 1 then
0
else
Z.add 1 (log2 (Z.div (Z.add x 1) 2)).
(* ❌ Functors are not handled. *)
functor
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (h : Blake2.Blake2b.hash)
: unit :=
let 'Hex h := to_hex h in
Format.pp_print_string ppf h.
Definition pp_short (ppf : Stdlib.Format.formatter) (h : Blake2.Blake2b.hash)
: unit :=
let 'Hex h := to_hex h in
Format.pp_print_string ppf (Stdlib.String.sub h 0 8).
src/lib_crypto/block_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make
(Base58)
(struct
let name = "block_hash"
let title = "A block identifier"
let b58check_prefix = Base58.Prefix.block_hash
let size = None
end)
module Logging = struct
let tag = Tag.def ~doc:"Block Hash" "block_hash" pp_short
let predecessor_tag =
Tag.def ~doc:"Block Predecessor Hash" "predecessor_hash" pp_short
end
let () = Base58.check_encoded_prefix b58check_encoding "B" 51
src/lib_crypto/block_hash.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Module Logging.
Definition tag : Tezos_stdlib.Tag.def t :=
Tag.def (Some "Block Hash" % string) "block_hash" % string pp_short.
Definition predecessor_tag : Tezos_stdlib.Tag.def t :=
Tag.def (Some "Block Predecessor Hash" % string) "predecessor_hash" % string
pp_short.
End Logging.
src/lib_crypto/chain_id.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
type t = string
let name = "Chain_id"
let title = "Network identifier"
let extract bh = Bytes.sub_string (Block_hash.to_bytes bh) 0 4
let hash_bytes ?key l = extract (Block_hash.hash_bytes ?key l)
let hash_string ?key l = extract (Block_hash.hash_string ?key l)
let size = 4
let of_string_opt s = if String.length s <> size then None else Some s
let of_string s =
match of_string_opt s with
| None ->
generic_error
"%s.of_string: wrong string size (%d)"
name
(String.length s)
| Some h ->
Ok h
let of_string_exn s =
match of_string_opt s with
| None ->
Format.kasprintf
invalid_arg
"%s.of_string_exn: wrong string size (%d)"
name
(String.length s)
| Some h ->
h
let to_string s = s
let of_hex s = of_string (Hex.to_string s)
let of_hex_opt s = of_string_opt (Hex.to_string s)
let of_hex_exn s = of_string_exn (Hex.to_string s)
let to_hex s = Hex.of_string (to_string s)
let of_bytes_opt b =
if Bytes.length b <> size then None else Some (Bytes.to_string b)
let of_bytes_exn b =
match of_bytes_opt b with
| None ->
let msg =
Printf.sprintf
"%s.of_bytes: wrong string size (%d)"
name
(Bytes.length b)
in
raise (Invalid_argument msg)
| Some h ->
h
let of_bytes s =
match of_bytes_opt s with
| Some x ->
Ok x
| None ->
generic_error "Failed to deserialize a hash (%s)" name
let to_bytes = Bytes.of_string
let path_length = 1
let to_path key l =
let (`Hex h) = to_hex key in
h :: l
let of_path path =
let path = String.concat "" path in
of_hex_opt (`Hex path)
let of_path_exn path =
let path = String.concat "" path in
of_hex_exn (`Hex path)
let prefix_path p =
let (`Hex p) = Hex.of_string p in
[p]
let zero = of_hex_exn (`Hex (String.make (size * 2) '0'))
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.chain_id
~length:size
~wrap:(fun s -> Data s)
~of_raw:of_string_opt
~to_raw:to_string
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let hash h = Int32.to_int (TzEndian.get_int32 (to_bytes h) 0)
let of_block_hash bh = hash_bytes [Block_hash.to_bytes bh]
include Compare.Make (struct
type nonrec t = t
let compare = String.compare
end)
include Helpers.Make (struct
type nonrec t = t
let title = title
let name = name
let b58check_encoding = b58check_encoding
let raw_encoding = raw_encoding
let compare = compare
let equal = equal
let hash = hash
end)
src/lib_crypto/chain_id.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Definition t := string.
Definition name : string := "Chain_id" % string.
Definition title : string := "Network identifier" % string.
Definition extract (bh : Tezos_crypto.Block_hash.t) : string :=
Stdlib.Bytes.sub_string (Block_hash.to_bytes bh) 0 4.
Definition hash_bytes (key : option Stdlib.Bytes.t) (l : list Stdlib.Bytes.t)
: string := extract (Block_hash.hash_bytes key l).
Definition hash_string (key : option string) (l : list string) : string :=
extract (Block_hash.hash_string key l).
Definition size : Z := 4.
Definition of_string_opt (s : string) : option string :=
if nequiv_decb (OCaml.String.length s) size then
None
else
Some s.
Definition of_string (s : string)
: Tezos_error_monad.Error_monad.tzresult string :=
match of_string_opt s with
| None =>
generic_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
".of_string: wrong string size (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s.of_string: wrong string size (%d)" % string) name
(OCaml.String.length s)
| Some h => Stdlib.Ok h
end.
Definition of_string_exn (s : string) : string :=
match of_string_opt s with
| None =>
Format.kasprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
".of_string_exn: wrong string size (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s.of_string_exn: wrong string size (%d)" % string) name
(OCaml.String.length s)
| Some h => h
end.
Definition to_string {A : Type} (s : A) : A := s.
Definition of_hex (s : Hex.t) : Tezos_error_monad.Error_monad.tzresult string :=
of_string (Hex.to_string s).
Definition of_hex_opt (s : Hex.t) : option string :=
of_string_opt (Hex.to_string s).
Definition of_hex_exn (s : Hex.t) : string := of_string_exn (Hex.to_string s).
Definition to_hex (s : string) : Hex.t := Hex.of_string None (to_string s).
Definition of_bytes_opt (b : string) : option string :=
if nequiv_decb (String.length b) size then
None
else
Some (Stdlib.Bytes.to_string b).
Definition of_bytes_exn (b : string) : string :=
match of_bytes_opt b with
| None =>
let msg :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
".of_bytes: wrong string size (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s.of_bytes: wrong string size (%d)" % string) name (String.length b)
in
Stdlib.raise (OCaml.Invalid_argument msg)
| Some h => h
end.
Definition of_bytes (s : string)
: sum string Tezos_error_monad.Error_monad.trace :=
match of_bytes_opt s with
| Some x => Stdlib.Ok x
| None =>
generic_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to deserialize a hash (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Failed to deserialize a hash (%s)" % string) name
end.
Definition to_bytes : string -> string := Stdlib.Bytes.of_string.
Definition path_length : Z := 1.
Definition to_path (key : string) (l : list string) : list string :=
let 'Hex h := to_hex key in
cons h l.
Definition of_path (path : list string) : option string :=
let path := Stdlib.String.concat "" % string path in
of_hex_opt
(* ❌ Variants not supported *)
variant.
Definition of_path_exn (path : list string) : string :=
let path := Stdlib.String.concat "" % string path in
of_hex_exn
(* ❌ Variants not supported *)
variant.
Definition prefix_path (p : string) : list string :=
let 'Hex p := Hex.of_string None p in
cons p [].
Definition zero : string :=
of_hex_exn
(* ❌ Variants not supported *)
variant.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.chain_id size to_string of_string_opt
(fun s => Tezos_crypto.Base58.Data s).
Definition raw_encoding : Tezos_data_encoding.Data_encoding.encoding string :=
conv to_bytes of_bytes_exn None (Fixed.bytes size).
Definition hash (h : string) : Z :=
Int32.to_int (TzEndian.get_int32 (to_bytes h) 0).
Definition of_block_hash (bh : Tezos_crypto.Block_hash.t) : string :=
hash_bytes None (cons (Block_hash.to_bytes bh) []).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
src/lib_crypto/context_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make
(Base58)
(struct
let name = "Context_hash"
let title = "A hash of context"
let b58check_prefix = Base58.Prefix.context_hash
let size = None
end)
let () = Base58.check_encoded_prefix b58check_encoding "Co" 52
src/lib_crypto/context_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_crypto/crypto_box.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Tezos - X25519/XSalsa20-Poly1305 cryptography *)
open Hacl
type secret_key = secret Box.key
type public_key = public Box.key
type channel_key = Box.combined Box.key
type nonce = Bigstring.t
type target = Z.t
module Secretbox = struct
include Secretbox
let box_noalloc key nonce msg = box ~key ~nonce ~msg ~cmsg:msg
let box_open_noalloc key nonce cmsg = box_open ~key ~nonce ~cmsg ~msg:cmsg
let box key msg nonce =
let msglen = Bytes.length msg in
let cmsg = Bigstring.make (msglen + zerobytes) '\x00' in
Bigstring.blit_of_bytes msg 0 cmsg zerobytes msglen ;
box ~key ~nonce ~msg:cmsg ~cmsg ;
Bigstring.sub cmsg boxzerobytes (msglen + zerobytes - boxzerobytes)
let box_open key cmsg nonce =
let cmsglen = Bigstring.length cmsg in
let msg = Bigstring.make (cmsglen + boxzerobytes) '\x00' in
Bigstring.blit cmsg 0 msg boxzerobytes cmsglen ;
match box_open ~key ~nonce ~cmsg:msg ~msg with
| false ->
None
| true ->
Some (Bigstring.sub_bytes msg zerobytes (cmsglen - boxzerobytes))
end
module Public_key_hash =
Blake2B.Make
(Base58)
(struct
let name = "Crypto_box.Public_key_hash"
let title = "A Cryptobox public key ID"
let b58check_prefix = Base58.Prefix.cryptobox_public_key_hash
let size = Some 16
end)
let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "id" 30
let hash pk =
Public_key_hash.hash_bytes [Bigstring.to_bytes (Box.unsafe_to_bytes pk)]
let zerobytes = Box.zerobytes
let boxzerobytes = Box.boxzerobytes
let random_keypair () =
let (pk, sk) = Box.keypair () in
(sk, pk, hash pk)
let zero_nonce = Bigstring.make Nonce.bytes '\x00'
let random_nonce = Nonce.gen
let increment_nonce = Nonce.increment
let generate_nonce bytes_list =
let hash = Blake2B.hash_bytes bytes_list in
let s = Bigstring.of_bytes (Blake2B.to_bytes hash) in
Nonce.of_bytes_exn @@ Bigstring.sub s 0 Nonce.bytes
let init_to_resp_seed = Bytes.of_string "Init -> Resp"
let resp_to_init_seed = Bytes.of_string "Resp -> Init"
let generate_nonces ~incoming ~sent_msg ~recv_msg =
let ((init_msg, resp_msg, false) | (resp_msg, init_msg, true)) =
(sent_msg, recv_msg, incoming)
in
let nonce_init_to_resp =
generate_nonce [init_msg; resp_msg; init_to_resp_seed]
in
let nonce_resp_to_init =
generate_nonce [init_msg; resp_msg; resp_to_init_seed]
in
if incoming then (nonce_init_to_resp, nonce_resp_to_init)
else (nonce_resp_to_init, nonce_init_to_resp)
let precompute sk pk = Box.dh pk sk
let fast_box_noalloc k nonce bmsg =
let msg = Bigstring.of_bytes bmsg in
Box.box ~k ~nonce ~msg ~cmsg:msg ;
Bigstring.blit_to_bytes msg 0 bmsg 0 (Bytes.length bmsg)
let fast_box_open_noalloc k nonce bcmsg =
let cmsg = Bigstring.of_bytes bcmsg in
if Box.box_open ~k ~nonce ~cmsg ~msg:cmsg then (
Bigstring.blit_to_bytes cmsg 0 bcmsg 0 (Bytes.length bcmsg) ;
true )
else false
let fast_box k msg nonce =
let msglen = Bigstring.length msg in
let cmsg = Bigstring.make (msglen + zerobytes) '\x00' in
Bigstring.blit msg 0 cmsg zerobytes msglen ;
Box.box ~k ~nonce ~msg:cmsg ~cmsg ;
cmsg
let fast_box_open k cmsg nonce =
let cmsglen = Bigstring.length cmsg in
let msg = Bigstring.make cmsglen '\x00' in
match Box.box_open ~k ~nonce ~cmsg ~msg with
| false ->
None
| true ->
Some (Bigstring.sub msg zerobytes (cmsglen - zerobytes))
let compare_target hash target =
let hash = Z.of_bits (Blake2B.to_string hash) in
Z.compare hash target <= 0
let make_target f =
if f < 0. || 256. < f then invalid_arg "Cryptobox.target_of_float" ;
let (frac, shift) = modf f in
let shift = int_of_float shift in
let m =
Z.of_int64
@@
if frac = 0. then Int64.(pred (shift_left 1L 54))
else Int64.of_float (2. ** (54. -. frac))
in
if shift < 202 then
Z.logor
(Z.shift_left m (202 - shift))
(Z.pred @@ Z.shift_left Z.one (202 - shift))
else Z.shift_right m (shift - 202)
let default_target = make_target 24.
let check_proof_of_work pk nonce target =
let hash =
Blake2B.hash_bytes
[Bigstring.to_bytes (Box.unsafe_to_bytes pk); Bigstring.to_bytes nonce]
in
compare_target hash target
let generate_proof_of_work ?max pk target =
let may_interupt =
match max with
| None ->
fun _ -> ()
| Some max ->
fun cpt -> if max < cpt then raise Not_found
in
let rec loop nonce cpt =
may_interupt cpt ;
if check_proof_of_work pk nonce target then nonce
else loop (Nonce.increment nonce) (cpt + 1)
in
loop (random_nonce ()) 0
let public_key_to_bytes pk = Bigstring.to_bytes (Box.unsafe_to_bytes pk)
let public_key_of_bytes buf = Box.unsafe_pk_of_bytes (Bigstring.of_bytes buf)
let public_key_size = Box.pkbytes
let secret_key_to_bytes sk = Bigstring.to_bytes (Box.unsafe_to_bytes sk)
let secret_key_of_bytes buf = Box.unsafe_sk_of_bytes (Bigstring.of_bytes buf)
let secret_key_size = Box.skbytes
let nonce_size = Nonce.bytes
let public_key_encoding =
let open Data_encoding in
conv public_key_to_bytes public_key_of_bytes (Fixed.bytes public_key_size)
let secret_key_encoding =
let open Data_encoding in
conv secret_key_to_bytes secret_key_of_bytes (Fixed.bytes secret_key_size)
let nonce_encoding =
let open Data_encoding in
conv Bigstring.to_bytes Bigstring.of_bytes (Fixed.bytes nonce_size)
let neuterize : secret_key -> public_key = Box.neuterize
let equal : public_key -> public_key -> bool = Box.equal
let pp_pk ppf pk = Hex.pp ppf (Hex.of_bytes (public_key_to_bytes pk))
src/lib_crypto/crypto_box.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Hacl.
Definition secret_key := Hacl.Box.key Hacl.secret.
Definition public_key := Hacl.Box.key Hacl.public.
Definition channel_key := Hacl.Box.key Hacl.Box.combined.
Definition nonce := Bigstring.t.
Definition target := Z.t.
Module Secretbox.
(* ❌ Structure item `include` not handled. *)
include
Definition box_noalloc (key : key) (nonce : Bigstring.t) (msg : Bigstring.t)
: unit := box key nonce msg msg.
Definition box_open_noalloc
(key : key) (nonce : Bigstring.t) (cmsg : Bigstring.t) : bool :=
box_open key nonce cmsg cmsg.
Definition box (key : key) (msg : Stdlib.Bytes.t) (nonce : Bigstring.t)
: Bigstring.t :=
let msglen := String.length msg in
let cmsg := Bigstring.make (Z.add msglen zerobytes) "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_bytes msg 0 cmsg zerobytes msglen in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := box key nonce cmsg cmsg in
Bigstring.sub cmsg boxzerobytes
(Z.sub (Z.add msglen zerobytes) boxzerobytes).
Definition box_open (key : key) (cmsg : Bigstring.t) (nonce : Bigstring.t)
: option Stdlib.Bytes.t :=
let cmsglen := Bigstring.length cmsg in
let msg := Bigstring.make (Z.add cmsglen boxzerobytes) "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit cmsg 0 msg boxzerobytes cmsglen in
match box_open key nonce msg msg with
| false => None
| true =>
Some (Bigstring.sub_bytes msg zerobytes (Z.sub cmsglen boxzerobytes))
end.
End Secretbox.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition hash {A : Type} (pk : Hacl.Box.key A)
: Public_key_hash.(Tezos_crypto__S.HASH.t) :=
Public_key_hash.(Tezos_crypto__S.HASH.hash_bytes) None
(cons (Bigstring.to_bytes (Box.unsafe_to_bytes pk)) []).
Definition zerobytes : Z := Box.zerobytes.
Definition boxzerobytes : Z := Box.boxzerobytes.
Definition random_keypair (function_parameter : unit)
: (Hacl.Box.key Hacl.secret) * (Hacl.Box.key Hacl.public) *
Public_key_hash.(Tezos_crypto__S.HASH.t) :=
let 'tt := function_parameter in
let '(pk, sk) := Box.keypair tt in
(sk, pk, (hash pk)).
Definition zero_nonce : Bigstring.t := Bigstring.make Nonce.bytes "000" % char.
Definition random_nonce : unit -> Hacl.Nonce.t := Nonce.gen.
Definition increment_nonce : (option Z) -> Hacl.Nonce.t -> Hacl.Nonce.t :=
Nonce.increment.
Definition generate_nonce (bytes_list : list Stdlib.Bytes.t) : Hacl.Nonce.t :=
let hash := Blake2B.hash_bytes None bytes_list in
let s := Bigstring.of_bytes (Blake2B.to_bytes hash) in
apply Nonce.of_bytes_exn (Bigstring.sub s 0 Nonce.bytes).
Definition init_to_resp_seed : string :=
Stdlib.Bytes.of_string "Init -> Resp" % string.
Definition resp_to_init_seed : string :=
Stdlib.Bytes.of_string "Resp -> Init" % string.
Definition generate_nonces
(incoming : bool) (sent_msg : Stdlib.Bytes.t) (recv_msg : Stdlib.Bytes.t)
: Hacl.Nonce.t * Hacl.Nonce.t :=
let '(init_msg, resp_msg, false) | (resp_msg, init_msg, true) :=
(sent_msg, recv_msg, incoming) in
let nonce_init_to_resp :=
generate_nonce (cons init_msg (cons resp_msg (cons init_to_resp_seed [])))
in
let nonce_resp_to_init :=
generate_nonce (cons init_msg (cons resp_msg (cons resp_to_init_seed [])))
in
if incoming then
(nonce_init_to_resp, nonce_resp_to_init)
else
(nonce_resp_to_init, nonce_init_to_resp).
Definition precompute
(sk : Hacl.Box.key Hacl.secret) (pk : Hacl.Box.key Hacl.public)
: Hacl.Box.key Hacl.Box.combined := Box.dh pk sk.
Definition fast_box_noalloc
(k : Hacl.Box.key Hacl.Box.combined) (nonce : Bigstring.t)
(bmsg : Stdlib.Bytes.t) : unit :=
let msg := Bigstring.of_bytes bmsg in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Box.box k nonce msg msg in
Bigstring.blit_to_bytes msg 0 bmsg 0 (String.length bmsg).
Definition fast_box_open_noalloc
(k : Hacl.Box.key Hacl.Box.combined) (nonce : Bigstring.t)
(bcmsg : Stdlib.Bytes.t) : bool :=
let cmsg := Bigstring.of_bytes bcmsg in
if Box.box_open k nonce cmsg cmsg then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_to_bytes cmsg 0 bcmsg 0 (String.length bcmsg) in
true
else
false.
Definition fast_box
(k : Hacl.Box.key Hacl.Box.combined) (msg : Bigstring.t) (nonce : Bigstring.t)
: Bigstring.t :=
let msglen := Bigstring.length msg in
let cmsg := Bigstring.make (Z.add msglen zerobytes) "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit msg 0 cmsg zerobytes msglen in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Box.box k nonce cmsg cmsg in
cmsg.
Definition fast_box_open
(k : Hacl.Box.key Hacl.Box.combined) (cmsg : Bigstring.t)
(nonce : Bigstring.t) : option Bigstring.t :=
let cmsglen := Bigstring.length cmsg in
let msg := Bigstring.make cmsglen "000" % char in
match Box.box_open k nonce cmsg msg with
| false => None
| true => Some (Bigstring.sub msg zerobytes (Z.sub cmsglen zerobytes))
end.
Definition compare_target (hash : Tezos_crypto.Blake2B.t) (target : Z.t)
: bool :=
let hash := Z.of_bits (Blake2B.to_string hash) in
OCaml.Stdlib.le (Z.compare hash target) 0.
Definition make_target (f : Z) : Z.t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb
(OCaml.Stdlib.lt f
(* ❌ Float constant 0. is approximated by the integer 0 *)
0)
(OCaml.Stdlib.lt
(* ❌ Float constant 256. is approximated by the integer 256 *)
256 f) then
OCaml.Stdlib.invalid_arg "Cryptobox.target_of_float" % string
else
tt in
let '(frac, shift) := Stdlib.modf f in
let shift := Stdlib.int_of_float shift in
let m :=
apply Z.of_int64
(if
equiv_decb frac
(* ❌ Float constant 0. is approximated by the integer 0 *)
0 then
pred
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 54)
else
Int64.of_float
(Stdlib.op_starstar
(* ❌ Float constant 2. is approximated by the integer 2 *)
2
(Stdlib.op_minuspoint
(* ❌ Float constant 54. is approximated by the integer 54 *)
54 frac))) in
if OCaml.Stdlib.lt shift 202 then
Z.logor (Z.shift_left m (Z.sub 202 shift))
(apply Z.pred (Z.shift_left Z.one (Z.sub 202 shift)))
else
Z.shift_right m (Z.sub shift 202).
Definition default_target : Z.t :=
make_target
(* ❌ Float constant 24. is approximated by the integer 24 *)
24.
Definition check_proof_of_work {A : Type}
(pk : Hacl.Box.key A) (nonce : Bigstring.t) (target : Z.t) : bool :=
let hash :=
Blake2B.hash_bytes None
(cons (Bigstring.to_bytes (Box.unsafe_to_bytes pk))
(cons (Bigstring.to_bytes nonce) [])) in
compare_target hash target.
Definition generate_proof_of_work {A : Type}
(max : option Z) (pk : Hacl.Box.key A) (target : Z.t) : Bigstring.t :=
let may_interupt :=
match max with
| None =>
fun function_parameter =>
let '_ := function_parameter in
tt
| Some max =>
fun cpt =>
if OCaml.Stdlib.lt max cpt then
Stdlib.raise OCaml.Not_found
else
tt
end in
let fix loop (nonce : Bigstring.t) (cpt : Z) : Bigstring.t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_interupt cpt in
if check_proof_of_work pk nonce target then
nonce
else
loop (Nonce.increment None nonce) (Z.add cpt 1) in
loop (random_nonce tt) 0.
Definition public_key_to_bytes {A : Type} (pk : Hacl.Box.key A)
: Stdlib.Bytes.t := Bigstring.to_bytes (Box.unsafe_to_bytes pk).
Definition public_key_of_bytes (buf : Stdlib.Bytes.t)
: Hacl.Box.key Hacl.public := Box.unsafe_pk_of_bytes (Bigstring.of_bytes buf).
Definition public_key_size : Z := Box.pkbytes.
Definition secret_key_to_bytes {A : Type} (sk : Hacl.Box.key A)
: Stdlib.Bytes.t := Bigstring.to_bytes (Box.unsafe_to_bytes sk).
Definition secret_key_of_bytes (buf : Stdlib.Bytes.t)
: Hacl.Box.key Hacl.secret := Box.unsafe_sk_of_bytes (Bigstring.of_bytes buf).
Definition secret_key_size : Z := Box.skbytes.
Definition nonce_size : Z := Nonce.bytes.
Definition public_key_encoding
: Tezos_data_encoding.Data_encoding.encoding (Hacl.Box.key Hacl.public) :=
conv public_key_to_bytes public_key_of_bytes None
(Fixed.bytes public_key_size).
Definition secret_key_encoding
: Tezos_data_encoding.Data_encoding.encoding (Hacl.Box.key Hacl.secret) :=
conv secret_key_to_bytes secret_key_of_bytes None
(Fixed.bytes secret_key_size).
Definition nonce_encoding
: Tezos_data_encoding.Data_encoding.encoding Bigstring.t :=
conv Bigstring.to_bytes Bigstring.of_bytes None (Fixed.bytes nonce_size).
Definition neuterize : secret_key -> public_key := Box.neuterize.
Definition equal : public_key -> public_key -> bool := Box.equal.
Definition pp_pk {A : Type}
(ppf : Stdlib.Format.formatter) (pk : Hacl.Box.key A) : unit :=
Hex.pp ppf (Hex.of_bytes None (public_key_to_bytes pk)).
src/lib_crypto/ed25519.ml 33 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module Public_key_hash = struct
include Blake2B.Make
(Base58)
(struct
let name = "Ed25519.Public_key_hash"
let title = "An Ed25519 public key hash"
let b58check_prefix = Base58.Prefix.ed25519_public_key_hash
let size = Some 20
end)
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
end
let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz1" 36
open Hacl
module Public_key = struct
type t = public Sign.key
let name = "Ed25519.Public_key"
let title = "Ed25519 public key"
let to_string s = Bigstring.to_string (Sign.unsafe_to_bytes s)
let of_string_opt s =
if String.length s < Sign.pkbytes then None
else
let pk = Bigstring.create Sign.pkbytes in
Bigstring.blit_of_string s 0 pk 0 Sign.pkbytes ;
Some (Sign.unsafe_pk_of_bytes pk)
let to_bytes pk = Bigstring.to_bytes (Sign.unsafe_to_bytes pk)
let of_bytes_opt buf =
let buflen = Bytes.length buf in
if buflen < Sign.pkbytes then None
else
let pk = Bigstring.create Sign.pkbytes in
Bigstring.blit_of_bytes buf 0 pk 0 Sign.pkbytes ;
Some (Sign.unsafe_pk_of_bytes pk)
let size = Sign.pkbytes
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_public_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "edpk" 54
let hash v =
Public_key_hash.hash_bytes [Bigstring.to_bytes (Sign.unsafe_to_bytes v)]
include Compare.Make (struct
type nonrec t = t
let compare a b =
Bigstring.compare (Sign.unsafe_to_bytes a) (Sign.unsafe_to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
module Secret_key = struct
type t = secret Sign.key
let name = "Ed25519.Secret_key"
let title = "An Ed25519 secret key"
let size = Sign.skbytes
let to_bigstring sk = Sign.unsafe_to_bytes sk
let to_bytes sk = Bigstring.to_bytes (to_bigstring sk)
let of_bytes_opt s =
if Bytes.length s > 64 then None
else
let sk = Bigstring.create Sign.skbytes in
Bigstring.blit_of_bytes s 0 sk 0 Sign.skbytes ;
Some (Sign.unsafe_sk_of_bytes sk)
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let to_public_key = Sign.neuterize
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_seed
~length:size
~to_raw:(fun sk -> Bigstring.to_string (Sign.unsafe_to_bytes sk))
~of_raw:(fun buf ->
if String.length buf <> Sign.skbytes then None
else Some (Sign.unsafe_sk_of_bytes (Bigstring.of_string buf)))
~wrap:(fun sk -> Data sk)
(* Legacy NaCl secret key encoding. Used to store both sk and pk. *)
let secret_key_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_secret_key
~length:Sign.(skbytes + pkbytes)
~to_raw:(fun sk ->
let pk = Sign.neuterize sk in
let buf = Bigstring.create Sign.(skbytes + pkbytes) in
Sign.blit_to_bytes sk buf ;
Sign.blit_to_bytes pk ~pos:Sign.skbytes buf ;
Bigstring.to_string buf)
~of_raw:(fun buf ->
if String.length buf <> Sign.(skbytes + pkbytes) then None
else
let sk = Bigstring.create Sign.skbytes in
Bigstring.blit_of_string buf 0 sk 0 Sign.skbytes ;
Some (Sign.unsafe_sk_of_bytes sk))
~wrap:(fun x -> Data x)
let of_b58check_opt s =
match Base58.simple_decode b58check_encoding s with
| Some x ->
Some x
| None ->
Base58.simple_decode secret_key_encoding s
let of_b58check_exn s =
match of_b58check_opt s with
| Some x ->
x
| None ->
Format.kasprintf Pervasives.failwith "Unexpected data (%s)" name
let of_b58check s =
match of_b58check_opt s with
| Some x ->
Ok x
| None ->
generic_error "Failed to read a b58check_encoding data (%s): %S" name s
let to_b58check s = Base58.simple_encode b58check_encoding s
let to_short_b58check s =
String.sub
(to_b58check s)
0
(10 + String.length (Base58.prefix b58check_encoding))
let () =
Base58.check_encoded_prefix b58check_encoding "edsk" 54 ;
Base58.check_encoded_prefix secret_key_encoding "edsk" 98
include Compare.Make (struct
type nonrec t = t
let compare a b =
Bigstring.compare (Sign.unsafe_to_bytes a) (Sign.unsafe_to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
type t = Bigstring.t
type watermark = Bytes.t
let name = "Ed25519"
let title = "An Ed25519 signature"
let size = Sign.bytes
let of_bytes_opt s =
if Bytes.length s = size then Some (Bigstring.of_bytes s) else None
let to_bytes x = Bigstring.to_bytes x
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_signature
~length:size
~to_raw:Bigstring.to_string
~of_raw:(fun s -> Some (Bigstring.of_string s))
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "edsig" 99
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
let zero = Bigstring.make size '\000'
let sign ?watermark sk msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
let signature = Bigstring.create Sign.bytes in
Sign.sign ~sk ~msg:(Bigstring.of_bytes msg) ~signature ;
signature
let check ?watermark pk signature msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
Sign.verify ~pk ~signature ~msg:(Bigstring.of_bytes msg)
let generate_key ?seed () =
match seed with
| None ->
let (pk, sk) = Sign.keypair () in
(Public_key.hash pk, pk, sk)
| Some seed ->
let seedlen = Bigstring.length seed in
if seedlen < Sign.skbytes then
invalid_arg
(Printf.sprintf
"Ed25519.generate_key: seed must be at least %d bytes long (got \
%d)"
Sign.skbytes
seedlen) ;
let sk = Bigstring.create Sign.skbytes in
Bigstring.blit seed 0 sk 0 Sign.skbytes ;
let sk = Sign.unsafe_sk_of_bytes sk in
let pk = Sign.neuterize sk in
(Public_key.hash pk, pk, sk)
let deterministic_nonce sk msg =
let msg = Bigstring.of_bytes msg in
let key = Secret_key.to_bigstring sk in
Hash.SHA256.HMAC.digest ~key ~msg
let deterministic_nonce_hash sk msg =
Blake2B.to_bytes
(Blake2B.hash_bytes [Bigstring.to_bytes (deterministic_nonce sk msg)])
include Compare.Make (struct
type nonrec t = t
let compare = Bigstring.compare
end)
src/lib_crypto/ed25519.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module Public_key_hash.
(* ❌ Structure item `include` not handled. *)
include
Module Logging.
Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
End Logging.
End Public_key_hash.
Import Hacl.
Module Public_key.
Definition t := Hacl.Sign.key Hacl.public.
Definition name : string := "Ed25519.Public_key" % string.
Definition title : string := "Ed25519 public key" % string.
Definition to_string {A : Type} (s : Hacl.Sign.key A) : string :=
Bigstring.to_string (Sign.unsafe_to_bytes s).
Definition of_string_opt (s : string) : option (Hacl.Sign.key Hacl.public) :=
if OCaml.Stdlib.lt (OCaml.String.length s) Sign.pkbytes then
None
else
let pk := Bigstring.create Sign.pkbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_string s 0 pk 0 Sign.pkbytes in
Some (Sign.unsafe_pk_of_bytes pk).
Definition to_bytes {A : Type} (pk : Hacl.Sign.key A) : Stdlib.Bytes.t :=
Bigstring.to_bytes (Sign.unsafe_to_bytes pk).
Definition of_bytes_opt (buf : Stdlib.Bytes.t)
: option (Hacl.Sign.key Hacl.public) :=
let buflen := String.length buf in
if OCaml.Stdlib.lt buflen Sign.pkbytes then
None
else
let pk := Bigstring.create Sign.pkbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_bytes buf 0 pk 0 Sign.pkbytes in
Some (Sign.unsafe_pk_of_bytes pk).
Definition size : Z := Sign.pkbytes.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.ed25519_public_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
Definition hash {A : Type} (v : Hacl.Sign.key A) : Public_key_hash.t :=
Public_key_hash.hash_bytes None
(cons (Bigstring.to_bytes (Sign.unsafe_to_bytes v)) []).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.
Module Secret_key.
Definition t := Hacl.Sign.key Hacl.secret.
Definition name : string := "Ed25519.Secret_key" % string.
Definition title : string := "An Ed25519 secret key" % string.
Definition size : Z := Sign.skbytes.
Definition to_bigstring {A : Type} (sk : Hacl.Sign.key A) : Bigstring.t :=
Sign.unsafe_to_bytes sk.
Definition to_bytes {A : Type} (sk : Hacl.Sign.key A) : Stdlib.Bytes.t :=
Bigstring.to_bytes (to_bigstring sk).
Definition of_bytes_opt (s : Stdlib.Bytes.t)
: option (Hacl.Sign.key Hacl.secret) :=
if OCaml.Stdlib.gt (String.length s) 64 then
None
else
let sk := Bigstring.create Sign.skbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_bytes s 0 sk 0 Sign.skbytes in
Some (Sign.unsafe_sk_of_bytes sk).
Definition to_string {A : Type} (s : Hacl.Sign.key A) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string) : option (Hacl.Sign.key Hacl.secret) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition to_public_key {A : Type}
: (Hacl.Sign.key A) -> Hacl.Sign.key Hacl.public := Sign.neuterize.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.ed25519_seed size
(fun sk => Bigstring.to_string (Sign.unsafe_to_bytes sk))
(fun buf =>
if nequiv_decb (OCaml.String.length buf) Sign.skbytes then
None
else
Some (Sign.unsafe_sk_of_bytes (Bigstring.of_string buf)))
(fun sk => Tezos_crypto.Base58.Data sk).
Definition secret_key_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.ed25519_secret_key
(Z.add skbytes pkbytes)
(fun sk =>
let pk := Sign.neuterize sk in
let buf := Bigstring.create (Z.add skbytes pkbytes) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sign.blit_to_bytes sk None buf in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sign.blit_to_bytes pk (Some Sign.skbytes) buf in
Bigstring.to_string buf)
(fun buf =>
if nequiv_decb (OCaml.String.length buf) (Z.add skbytes pkbytes) then
None
else
let sk := Bigstring.create Sign.skbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_string buf 0 sk 0 Sign.skbytes in
Some (Sign.unsafe_sk_of_bytes sk))
(fun x => Tezos_crypto.Base58.Data x).
Definition of_b58check_opt (s : string) : option t :=
match Base58.simple_decode None b58check_encoding s with
| Some x => Some x
| None => Base58.simple_decode None secret_key_encoding s
end.
Definition of_b58check_exn (s : string) : t :=
match of_b58check_opt s with
| Some x => x
| None =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Unexpected data (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Unexpected data (%s)" % string) name
end.
Definition of_b58check (s : string)
: sum t Tezos_error_monad.Error_monad.trace :=
match of_b58check_opt s with
| Some x => Stdlib.Ok x
| None =>
generic_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to read a b58check_encoding data (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "): " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Failed to read a b58check_encoding data (%s): %S" % string) name s
end.
Definition to_b58check (s : t) : string :=
Base58.simple_encode None b58check_encoding s.
Definition to_short_b58check (s : t) : string :=
Stdlib.String.sub (to_b58check s) 0
(Z.add 10 (OCaml.String.length (Base58.prefix b58check_encoding))).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.
Definition t := Bigstring.t.
Definition watermark := Stdlib.Bytes.t.
Definition name : string := "Ed25519" % string.
Definition title : string := "An Ed25519 signature" % string.
Definition size : Z := Sign.bytes.
Definition of_bytes_opt (s : Stdlib.Bytes.t) : option Bigstring.t :=
if equiv_decb (String.length s) size then
Some (Bigstring.of_bytes s)
else
None.
Definition to_bytes (x : Bigstring.t) : Stdlib.Bytes.t := Bigstring.to_bytes x.
Definition to_string (s : Bigstring.t) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string) : option Bigstring.t :=
of_bytes_opt (Stdlib.Bytes.of_string s).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding Bigstring.t :=
Base58.register_encoding Base58.Prefix.ed25519_signature size
Bigstring.to_string (fun s => Some (Bigstring.of_string s))
(fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
Definition zero : Bigstring.t := Bigstring.make size "000" % char.
Definition sign
(watermark : option Stdlib.Bytes.t) (sk : Hacl.Sign.key Hacl.secret)
(msg : Stdlib.Bytes.t) : Bigstring.t :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
let signature := Bigstring.create Sign.bytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sign.sign sk (Bigstring.of_bytes msg) signature in
signature.
Definition check
(watermark : option Stdlib.Bytes.t) (pk : Hacl.Sign.key Hacl.public)
(signature : Bigstring.t) (msg : Stdlib.Bytes.t) : bool :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
Sign.verify pk (Bigstring.of_bytes msg) signature.
Definition generate_key (seed : option Bigstring.t) (function_parameter : unit)
: Public_key_hash.t * (Hacl.Sign.key Hacl.public) *
(Hacl.Sign.key Hacl.secret) :=
let 'tt := function_parameter in
match seed with
| None =>
let '(pk, sk) := Sign.keypair tt in
((Public_key.hash pk), pk, sk)
| Some seed =>
let seedlen := Bigstring.length seed in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt seedlen Sign.skbytes then
OCaml.Stdlib.invalid_arg
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ed25519.generate_key: seed must be at least " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" bytes long (got " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Ed25519.generate_key: seed must be at least %d bytes long (got %d)"
% string) Sign.skbytes seedlen)
else
tt in
let sk := Bigstring.create Sign.skbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit seed 0 sk 0 Sign.skbytes in
let sk := Sign.unsafe_sk_of_bytes sk in
let pk := Sign.neuterize sk in
((Public_key.hash pk), pk, sk)
end.
Definition deterministic_nonce {A : Type}
(sk : Hacl.Sign.key A) (msg : Stdlib.Bytes.t) : Bigstring.t :=
let msg := Bigstring.of_bytes msg in
let key := Secret_key.to_bigstring sk in
Hash.SHA256.HMAC.digest key msg.
Definition deterministic_nonce_hash {A : Type}
(sk : Hacl.Sign.key A) (msg : Stdlib.Bytes.t) : Stdlib.Bytes.t :=
Blake2B.to_bytes
(Blake2B.hash_bytes None
(cons (Bigstring.to_bytes (deterministic_nonce sk msg)) [])).
(* ❌ Structure item `include` not handled. *)
include
src/lib_crypto/helpers.ml 5 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module MakeRaw (H : sig
type t
val name : string
val of_bytes_opt : Bytes.t -> t option
val to_string : t -> string
val of_string_opt : string -> t option
end) =
struct
let of_bytes_exn s =
match H.of_bytes_opt s with
| None ->
Format.kasprintf invalid_arg "of_bytes_exn (%s)" H.name
| Some pk ->
pk
let of_bytes s =
match H.of_bytes_opt s with
| None ->
generic_error "of_bytes (%s)" H.name
| Some pk ->
Ok pk
let of_string_exn s =
match H.of_string_opt s with
| None ->
Format.kasprintf invalid_arg "of_string_exn (%s)" H.name
| Some pk ->
pk
let of_string s =
match H.of_string_opt s with
| None ->
generic_error "of_string (%s)" H.name
| Some pk ->
Ok pk
let to_hex s = Hex.of_string (H.to_string s)
let of_hex_opt s = H.of_string_opt (Hex.to_string s)
let of_hex_exn s =
match H.of_string_opt (Hex.to_string s) with
| Some x ->
x
| None ->
Format.kasprintf invalid_arg "of_hex_exn (%s)" H.name
let of_hex s =
match of_hex_opt s with
| None ->
generic_error "of_hex (%s)" H.name
| Some pk ->
ok pk
end
module MakeB58 (H : sig
type t
val name : string
val b58check_encoding : t Base58.encoding
end) =
struct
let of_b58check_opt s = Base58.simple_decode H.b58check_encoding s
let of_b58check_exn s =
match of_b58check_opt s with
| Some x ->
x
| None ->
Format.kasprintf Pervasives.failwith "Unexpected data (%s)" H.name
let of_b58check s =
match of_b58check_opt s with
| Some x ->
Ok x
| None ->
generic_error
"Failed to read a b58check_encoding data (%s): %S"
H.name
s
let to_b58check s = Base58.simple_encode H.b58check_encoding s
let to_short_b58check s =
String.sub
(to_b58check s)
0
(10 + String.length (Base58.prefix H.b58check_encoding))
end
module MakeEncoder (H : sig
type t
val title : string
val name : string
val to_b58check : t -> string
val to_short_b58check : t -> string
val of_b58check : string -> t tzresult
val of_b58check_exn : string -> t
val of_b58check_opt : string -> t option
val raw_encoding : t Data_encoding.t
end) =
struct
let pp ppf t = Format.pp_print_string ppf (H.to_b58check t)
let pp_short ppf t = Format.pp_print_string ppf (H.to_short_b58check t)
let encoding =
let open Data_encoding in
splitted
~binary:(obj1 (req H.name H.raw_encoding))
~json:
( def H.name ~title:(H.title ^ " (Base58Check-encoded)")
@@ conv
H.to_b58check
(Data_encoding.Json.wrap_error H.of_b58check_exn)
string )
let of_b58check = H.of_b58check
let rpc_arg =
RPC_arg.make
~name:H.name
~descr:(Format.asprintf "%s (Base58Check-encoded)" H.name)
~destruct:(fun s ->
match H.of_b58check_opt s with
| None ->
Error
(Format.asprintf
"failed to decode Base58Check-encoded data (%s): %S"
H.name
s)
| Some v ->
Ok v)
~construct:H.to_b58check
()
end
module MakeIterator (H : sig
type t
val encoding : t Data_encoding.t
val compare : t -> t -> int
val equal : t -> t -> bool
val hash : t -> int
end) =
struct
module Set = struct
include Set.Make (struct
type t = H.t
let compare = H.compare
end)
exception Found of elt
let random_elt s =
let n = Random.int (cardinal s) in
try
ignore
( fold
(fun x i ->
if i = n then raise (Found x) ;
i + 1)
s
0
: int ) ;
assert false
with Found x -> x
let encoding =
Data_encoding.conv
elements
(fun l -> List.fold_left (fun m x -> add x m) empty l)
Data_encoding.(list H.encoding)
end
module Table = struct
include Hashtbl.Make (struct
type t = H.t
let hash = H.hash
let equal = H.equal
end)
let encoding arg_encoding =
Data_encoding.conv
(fun h -> fold (fun k v l -> (k, v) :: l) h [])
(fun l ->
let h = create (List.length l) in
List.iter (fun (k, v) -> add h k v) l ;
h)
Data_encoding.(list (tup2 H.encoding arg_encoding))
end
module Map = struct
include Map.Make (struct
type t = H.t
let compare = H.compare
end)
let encoding arg_encoding =
Data_encoding.conv
bindings
(fun l -> List.fold_left (fun m (k, v) -> add k v m) empty l)
Data_encoding.(list (tup2 H.encoding arg_encoding))
end
module Error_table = struct
include Error_table.Make (Table)
end
module WeakRingTable = struct
include WeakRingTable.Make (struct
type t = H.t
let hash = H.hash
let equal = H.equal
end)
let encoding arg_encoding =
Data_encoding.conv
(fun h -> fold (fun k v l -> (k, v) :: l) h [])
(fun l ->
let h = create (List.length l) in
List.iter (fun (k, v) -> add h k v) l ;
h)
Data_encoding.(list (tup2 H.encoding arg_encoding))
end
end
module Make (H : sig
type t
val title : string
val name : string
val b58check_encoding : t Base58.encoding
val raw_encoding : t Data_encoding.t
val compare : t -> t -> int
val equal : t -> t -> bool
val hash : t -> int
end) =
struct
include MakeB58 (H)
include MakeEncoder (struct
include H
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
end)
include MakeIterator (struct
include H
let encoding = encoding
end)
end
src/lib_crypto/helpers.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Import Error_monad. (* ❌ Functors are not handled. *) functor (* ❌ Functors are not handled. *) functor (* ❌ Functors are not handled. *) functor (* ❌ Functors are not handled. *) functor (* ❌ Functors are not handled. *) functor
src/lib_crypto/operation_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make
(Base58)
(struct
let name = "Operation_hash"
let title = "A Tezos operation ID"
let b58check_prefix = Base58.Prefix.operation_hash
let size = None
end)
let () = Base58.check_encoded_prefix b58check_encoding "o" 51
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
src/lib_crypto/operation_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include Module Logging. Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp. End Logging.
src/lib_crypto/operation_list_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make_merkle_tree
(Base58)
(struct
let name = "Operation_list_hash"
let title = "A list of operations"
let b58check_prefix = Base58.Prefix.operation_list_hash
let size = None
end)
(Operation_hash)
let () = Base58.check_encoded_prefix b58check_encoding "Lo" 52
src/lib_crypto/operation_list_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_crypto/operation_list_list_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make_merkle_tree
(Base58)
(struct
let name = "Operation_list_list_hash"
let title = "A list of list of operations"
let b58check_prefix = Base58.Prefix.operation_list_list_hash
let size = None
end)
(Operation_list_hash)
let () = Base58.check_encoded_prefix b58check_encoding "LLo" 53
src/lib_crypto/operation_list_list_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_crypto/p256.ml 24 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Public_key_hash = struct
include Blake2B.Make
(Base58)
(struct
let name = "P256.Public_key_hash"
let title = "A P256 public key hash"
let b58check_prefix = Base58.Prefix.p256_public_key_hash
let size = Some 20
end)
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
end
let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz3" 36
open Uecc
module Public_key = struct
type t = (secp256r1, public) key
let name = "P256.Public_key"
let title = "A P256 public key"
let to_bigstring = to_bytes ~compress:true
let to_bytes b = Bigstring.to_bytes (to_bigstring b)
let to_string s = Bytes.to_string (to_bytes s)
let of_bytes_opt b = pk_of_bytes secp256r1 (Bigstring.of_bytes b)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let size = compressed_size secp256r1
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.p256_public_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "p2pk" 55
let hash v = Public_key_hash.hash_bytes [to_bytes v]
include Compare.Make (struct
type nonrec t = t
let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
module Secret_key = struct
type t = (secp256r1, secret) key
let name = "P256.Secret_key"
let title = "A P256 secret key"
let size = sk_size secp256r1
let of_bytes_opt buf =
Option.map ~f:fst (sk_of_bytes secp256r1 (Bigstring.of_bytes buf))
let to_bigstring = to_bytes ~compress:true
let to_bytes t = Bigstring.to_bytes (to_bigstring t)
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let to_public_key = neuterize
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.p256_secret_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "p2sk" 54
include Compare.Make (struct
type nonrec t = t
let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
type t = Bigstring.t
type watermark = Bytes.t
let name = "P256"
let title = "A P256 signature"
let size = pk_size secp256r1
let of_bytes_opt s =
if Bytes.length s = size then Some (Bigstring.of_bytes s) else None
let to_bytes s = Bigstring.to_bytes s
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.p256_signature
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "p2sig" 98
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
let zero = of_bytes_exn (Bytes.make size '\000')
let sign ?watermark sk msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
match sign sk (Bigstring.of_bytes msg) with
| None ->
(* Will never happen in practice. This can only happen in case
of RNG error. *)
invalid_arg "P256.sign: internal error"
| Some signature ->
signature
let check ?watermark public_key signature msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
verify public_key ~msg:(Bigstring.of_bytes msg) ~signature
let generate_key ?(seed = Hacl.Rand.gen 32) () =
let seedlen = Bigstring.length seed in
if seedlen < 32 then
invalid_arg
(Printf.sprintf
"P256.generate_key: seed must be at least 32 bytes long (was %d)"
seedlen) ;
match sk_of_bytes secp256r1 seed with
| None ->
invalid_arg "P256.generate_key: invalid seed (very rare!)"
| Some (sk, pk) ->
let pkh = Public_key.hash pk in
(pkh, pk, sk)
let deterministic_nonce sk msg =
let msg = Bigstring.of_bytes msg in
let key = Secret_key.to_bigstring sk in
Hacl.Hash.SHA256.HMAC.digest ~key ~msg
let deterministic_nonce_hash sk msg =
let nonce = deterministic_nonce sk msg in
Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce])
include Compare.Make (struct
type nonrec t = t
let compare = Bigstring.compare
end)
src/lib_crypto/p256.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Public_key_hash.
(* ❌ Structure item `include` not handled. *)
include
Module Logging.
Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
End Logging.
End Public_key_hash.
Import Uecc.
Module Public_key.
Definition t := Uecc.key Uecc.secp256r1 Uecc.public.
Definition name : string := "P256.Public_key" % string.
Definition title : string := "A P256 public key" % string.
Definition to_bigstring
: (Uecc.key Uecc.secp256r1 Uecc.public) -> Bigstring.t :=
to_bytes (Some true).
Definition to_bytes (b : Uecc.key Uecc.secp256r1 Uecc.public)
: Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring b).
Definition to_string (s : Uecc.key Uecc.secp256r1 Uecc.public) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_bytes_opt (b : Stdlib.Bytes.t)
: option (Uecc.key Uecc.secp256r1 Uecc.public) :=
pk_of_bytes secp256r1 (Bigstring.of_bytes b).
Definition of_string_opt (s : string)
: option (Uecc.key Uecc.secp256r1 Uecc.public) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition size : Z := compressed_size secp256r1.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.p256_public_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
Definition hash (v : Uecc.key Uecc.secp256r1 Uecc.public)
: Public_key_hash.t :=
Public_key_hash.hash_bytes None (cons (to_bytes v) []).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.
Module Secret_key.
Definition t := Uecc.key Uecc.secp256r1 Uecc.secret.
Definition name : string := "P256.Secret_key" % string.
Definition title : string := "A P256 secret key" % string.
Definition size : Z := sk_size secp256r1.
Definition of_bytes_opt (buf : Stdlib.Bytes.t)
: option (Uecc.key Uecc.secp256r1 Uecc.secret) :=
Option.map fst (sk_of_bytes secp256r1 (Bigstring.of_bytes buf)).
Definition to_bigstring
: (Uecc.key Uecc.secp256r1 Uecc.secret) -> Bigstring.t :=
to_bytes (Some true).
Definition to_bytes (t : Uecc.key Uecc.secp256r1 Uecc.secret)
: Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring t).
Definition to_string (s : Uecc.key Uecc.secp256r1 Uecc.secret) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string)
: option (Uecc.key Uecc.secp256r1 Uecc.secret) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition to_public_key {A B : Type}
: (Uecc.key A B) -> Uecc.key A Uecc.public := neuterize.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.p256_secret_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.
Definition t := Bigstring.t.
Definition watermark := Stdlib.Bytes.t.
Definition name : string := "P256" % string.
Definition title : string := "A P256 signature" % string.
Definition size : Z := pk_size secp256r1.
Definition of_bytes_opt (s : Stdlib.Bytes.t) : option Bigstring.t :=
if equiv_decb (String.length s) size then
Some (Bigstring.of_bytes s)
else
None.
Definition to_bytes (s : Bigstring.t) : Stdlib.Bytes.t := Bigstring.to_bytes s.
Definition to_string (s : Bigstring.t) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string) : option Bigstring.t :=
of_bytes_opt (Stdlib.Bytes.of_string s).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding Bigstring.t :=
Base58.register_encoding Base58.Prefix.p256_signature size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
Definition zero : t := of_bytes_exn (Stdlib.Bytes.make size "000" % char).
Definition sign {A : Type}
(watermark : option Stdlib.Bytes.t) (sk : Uecc.key A Uecc.secret)
(msg : Stdlib.Bytes.t) : Bigstring.t :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
match sign sk (Bigstring.of_bytes msg) with
| None => OCaml.Stdlib.invalid_arg "P256.sign: internal error" % string
| Some signature => signature
end.
Definition check {A : Type}
(watermark : option Stdlib.Bytes.t) (public_key : Uecc.key A Uecc.public)
(signature : Bigstring.t) (msg : Stdlib.Bytes.t) : bool :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
verify public_key (Bigstring.of_bytes msg) signature.
Definition generate_key (op_staroptstar : option Bigstring.t)
: unit ->
Public_key_hash.t * (Uecc.key Uecc.secp256r1 Uecc.public) *
(Uecc.key Uecc.secp256r1 Uecc.secret) :=
let seed :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Hacl.Rand.gen 32
end in
fun function_parameter =>
let 'tt := function_parameter in
let seedlen := Bigstring.length seed in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt seedlen 32 then
OCaml.Stdlib.invalid_arg
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"P256.generate_key: seed must be at least 32 bytes long (was " %
string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"P256.generate_key: seed must be at least 32 bytes long (was %d)"
% string) seedlen)
else
tt in
match sk_of_bytes secp256r1 seed with
| None =>
OCaml.Stdlib.invalid_arg
"P256.generate_key: invalid seed (very rare!)" % string
| Some (sk, pk) =>
let pkh := Public_key.hash pk in
(pkh, pk, sk)
end.
Definition deterministic_nonce
(sk : Uecc.key Uecc.secp256r1 Uecc.secret) (msg : Stdlib.Bytes.t)
: Bigstring.t :=
let msg := Bigstring.of_bytes msg in
let key := Secret_key.to_bigstring sk in
Hacl.Hash.SHA256.HMAC.digest key msg.
Definition deterministic_nonce_hash
(sk : Uecc.key Uecc.secp256r1 Uecc.secret) (msg : Stdlib.Bytes.t)
: Stdlib.Bytes.t :=
let nonce := deterministic_nonce sk msg in
Blake2B.to_bytes
(Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])).
(* ❌ Structure item `include` not handled. *)
include
src/lib_crypto/protocol_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make
(Base58)
(struct
let name = "Protocol_hash"
let title = "A Tezos protocol ID"
let b58check_prefix = Base58.Prefix.protocol_hash
let size = None
end)
let () = Base58.check_encoded_prefix b58check_encoding "P" 51
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
src/lib_crypto/protocol_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include Module Logging. Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp. End Logging.
src/lib_crypto/pvss_secp256k1.ml 56 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Secp256k1_group
module G : Pvss.CYCLIC_GROUP = struct
module Z_m = struct
include Group.Scalar
let n = Group.order
let ( + ) = Group.Scalar.add
let ( * ) = Group.Scalar.mul
let ( - ) = Group.Scalar.sub
let ( = ) = Group.Scalar.equal
let inv = Group.Scalar.inverse
end
include Group
let name = "secp256k1"
(* This pvss algorithm assumes the public keys of the participants receiving
shares are based on g2, so we set g2 to Group.g to match regular Secp256k1
public keys.
*)
let g1 = Group.h
let g2 = Group.g
(* We use a multiplicative notation in the pvss module, but
secp256k1 usually uses an additive notation. *)
let ( * ) = Group.(( + ))
let pow x n = Group.mul n x
let of_bits b = try Some (Group.of_bits_exn b) with _ -> None
end
include Pvss.MakePvss (G)
src/lib_crypto/pvss_secp256k1.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Secp256k1_group.
Module G.
Module Z_m.
(* ❌ Structure item `include` not handled. *)
include
Definition n : Z.t := Group.order.
Definition op_plus
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.add.
Definition op_star
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.mul.
Definition op_minus
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.sub.
Definition op_eq
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t -> bool :=
Group.Scalar.equal.
Definition inv
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
option Tezos_crypto.Secp256k1_group.Group.Scalar.t :=
Group.Scalar.inverse.
End Z_m.
(* ❌ Structure item `include` not handled. *)
include
Definition name : string := "secp256k1" % string.
Definition g1 : Tezos_crypto.Secp256k1_group.Group.t := Group.h.
Definition g2 : Tezos_crypto.Secp256k1_group.Group.t := Group.g.
Definition op_star
: Tezos_crypto.Secp256k1_group.Group.t ->
Tezos_crypto.Secp256k1_group.Group.t ->
Tezos_crypto.Secp256k1_group.Group.t := op_plus.
Definition pow
(x : Tezos_crypto.Secp256k1_group.Group.t)
(n : Tezos_crypto.Secp256k1_group.Group.Scalar.t)
: Tezos_crypto.Secp256k1_group.Group.t := Group.mul n x.
Definition of_bits (b : string)
: option Tezos_crypto.Secp256k1_group.Group.t :=
(* ❌ Try-with are not handled *)
try (Some (Group.of_bits_exn b)).
End G.
(* ❌ Structure item `include` not handled. *)
include
src/lib_crypto/rand.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let generate len = Bigstring.to_bytes (Hacl.Rand.gen len)
let generate_into ?(pos = 0) ?len buf =
let buflen = Bytes.length buf in
let len = match len with Some len -> len | None -> buflen - pos in
if pos < 0 || len < 0 || pos + len > buflen then
invalid_arg
(Printf.sprintf
"Rand.generate_into: invalid slice (pos=%d len=%d)"
pos
len) ;
let rand = Hacl.Rand.gen len in
Bigstring.blit_to_bytes rand 0 buf pos len
src/lib_crypto/rand.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition generate (len : Z) : Stdlib.Bytes.t :=
Bigstring.to_bytes (Hacl.Rand.gen len).
Definition generate_into (op_staroptstar : option Z)
: (option Z) -> Stdlib.Bytes.t -> unit :=
let pos :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun len =>
fun buf =>
let buflen := String.length buf in
let len :=
match len with
| Some len => len
| None => Z.sub buflen pos
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb (OCaml.Stdlib.lt pos 0)
(orb (OCaml.Stdlib.lt len 0)
(OCaml.Stdlib.gt (Z.add pos len) buflen)) then
OCaml.Stdlib.invalid_arg
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Rand.generate_into: invalid slice (pos=" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " len=" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Rand.generate_into: invalid slice (pos=%d len=%d)" % string)
pos len)
else
tt in
let rand := Hacl.Rand.gen len in
Bigstring.blit_to_bytes rand 0 buf pos len.
src/lib_crypto/s.ml 31 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
(** {2 Hash Types} *)
(** The signature of an abstract hash type, as produced by functor
{!Make_Blake2B}. The {!t} type is abstracted for separating the
various kinds of hashes in the system at typing time. Each type is
equipped with functions to use it as is of as keys in the database
or in memory sets and maps. *)
module type MINIMAL_HASH = sig
type t
val name : string
val title : string
val pp : Format.formatter -> t -> unit
val pp_short : Format.formatter -> t -> unit
include Compare.S with type t := t
val hash_bytes : ?key:Bytes.t -> Bytes.t list -> t
val hash_string : ?key:string -> string list -> t
val zero : t
end
module type RAW_DATA = sig
type t
val size : int (* in bytes *)
val to_hex : t -> Hex.t
val of_hex : Hex.t -> t tzresult
val of_hex_opt : Hex.t -> t option
val of_hex_exn : Hex.t -> t
val to_string : t -> string
val of_string : string -> t tzresult
val of_string_opt : string -> t option
val of_string_exn : string -> t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t tzresult
val of_bytes_opt : Bytes.t -> t option
val of_bytes_exn : Bytes.t -> t
end
module type B58_DATA = sig
type t
val to_b58check : t -> string
val to_short_b58check : t -> string
val of_b58check : string -> t tzresult
val of_b58check_exn : string -> t
val of_b58check_opt : string -> t option
type Base58.data += Data of t
val b58check_encoding : t Base58.encoding
end
module type ENCODER = sig
type t
val encoding : t Data_encoding.t
val rpc_arg : t RPC_arg.t
end
module type PVSS = sig
type proof
module Clear_share : sig
type t
end
module Commitment : sig
type t
end
module Encrypted_share : sig
type t
end
module Public_key : sig
type t
include B58_DATA with type t := t
include ENCODER with type t := t
end
end
module type INDEXES = sig
type t
val hash : t -> int
val to_path : t -> string list -> string list
val of_path : string list -> t option
val of_path_exn : string list -> t
val prefix_path : string -> string list
val path_length : int
module Set : sig
include Set.S with type elt = t
val random_elt : t -> elt
val encoding : t Data_encoding.t
end
module Map : sig
include Map.S with type key = t
val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
end
module Table : sig
include Hashtbl.S with type key = t
val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
end
module Error_table : sig
include Error_table.S with type key = t
end
module WeakRingTable : sig
include WeakRingTable.S with type key = t
val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
end
end
module type HASH = sig
include MINIMAL_HASH
include RAW_DATA with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
include INDEXES with type t := t
end
module type MERKLE_TREE = sig
type elt
val elt_bytes : elt -> Bytes.t
include HASH
val compute : elt list -> t
val empty : t
type path = Left of path * t | Right of t * path | Op
val path_encoding : path Data_encoding.t
val bounded_path_encoding : ?max_length:int -> unit -> path Data_encoding.t
val compute_path : elt list -> int -> path
val check_path : path -> elt -> t * int
end
module type SIGNATURE = sig
module Public_key_hash : sig
type t
val pp : Format.formatter -> t -> unit
val pp_short : Format.formatter -> t -> unit
include Compare.S with type t := t
include RAW_DATA with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
include INDEXES with type t := t
val zero : t
module Logging : sig
val tag : t Tag.def
end
end
module Public_key : sig
type t
val pp : Format.formatter -> t -> unit
include Compare.S with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
val hash : t -> Public_key_hash.t
end
module Secret_key : sig
type t
val pp : Format.formatter -> t -> unit
include Compare.S with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
val to_public_key : t -> Public_key.t
end
type t
val pp : Format.formatter -> t -> unit
include Compare.S with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
val zero : t
type watermark
val sign : ?watermark:watermark -> Secret_key.t -> Bytes.t -> t
val check : ?watermark:watermark -> Public_key.t -> t -> Bytes.t -> bool
val generate_key :
?seed:Bigstring.t ->
unit ->
Public_key_hash.t * Public_key.t * Secret_key.t
val deterministic_nonce : Secret_key.t -> Bytes.t -> Bigstring.t
val deterministic_nonce_hash : Secret_key.t -> Bytes.t -> Bytes.t
end
src/lib_crypto/s.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module MINIMAL_HASH.
Record signature {t : Type} := {
t := t;
name : string;
title : string;
pp : Stdlib.Format.formatter -> t -> unit;
pp_short : Stdlib.Format.formatter -> t -> unit;
include;
hash_bytes : (option Stdlib.Bytes.t) -> (list Stdlib.Bytes.t) -> t;
hash_string : (option string) -> (list string) -> t;
zero : t;
}.
Arguments signature : clear implicits.
End MINIMAL_HASH.
Module RAW_DATA.
Record signature {t : Type} := {
t := t;
size : Z;
to_hex : t -> Hex.t;
of_hex : Hex.t -> Tezos_error_monad.Error_monad.tzresult t;
of_hex_opt : Hex.t -> option t;
of_hex_exn : Hex.t -> t;
to_string : t -> string;
of_string : string -> Tezos_error_monad.Error_monad.tzresult t;
of_string_opt : string -> option t;
of_string_exn : string -> t;
to_bytes : t -> Stdlib.Bytes.t;
of_bytes : Stdlib.Bytes.t -> Tezos_error_monad.Error_monad.tzresult t;
of_bytes_opt : Stdlib.Bytes.t -> option t;
of_bytes_exn : Stdlib.Bytes.t -> t;
}.
Arguments signature : clear implicits.
End RAW_DATA.
Module B58_DATA.
Record signature {t : Type} := {
t := t;
to_b58check : t -> string;
to_short_b58check : t -> string;
of_b58check : string -> Tezos_error_monad.Error_monad.tzresult t;
of_b58check_exn : string -> t;
of_b58check_opt : string -> option t;
extensible_type;
b58check_encoding : Tezos_crypto.Base58.encoding t;
}.
Arguments signature : clear implicits.
End B58_DATA.
Module ENCODER.
Record signature {t : Type} := {
t := t;
encoding : Tezos_data_encoding.Data_encoding.t t;
rpc_arg : Tezos_rpc.RPC_arg.t t;
}.
Arguments signature : clear implicits.
End ENCODER.
Module PVSS.
Record signature {proof Clear_share_t Commitment_t Encrypted_share_t
Public_key_t : Type} := {
proof := proof;
Clear_share : signature;
Commitment : signature;
Encrypted_share : signature;
Public_key : signature;
}.
Arguments signature : clear implicits.
End PVSS.
Module INDEXES.
Record signature {t Set_t Map_t Table_t Error_table_t WeakRingTable_t : Type}
:= {
t := t;
hash : t -> Z;
to_path : t -> (list string) -> list string;
of_path : (list string) -> option t;
of_path_exn : (list string) -> t;
prefix_path : string -> list string;
path_length : Z;
Set : signature;
Map : signature;
Table : signature;
Error_table : signature;
WeakRingTable : signature;
}.
Arguments signature : clear implicits.
End INDEXES.
Module HASH.
Record signature {t Set_t Map_t Table_t Error_table_t WeakRingTable_t : Type}
:= {
include;
include;
include;
include;
include;
}.
Arguments signature : clear implicits.
End HASH.
Module MERKLE_TREE.
Record signature {elt t Set_t Map_t Table_t Error_table_t WeakRingTable_t path
: Type} := {
elt := elt;
elt_bytes : elt -> Stdlib.Bytes.t;
include;
compute : (list elt) -> t;
empty : t;
path := path;
path_encoding : Tezos_data_encoding.Data_encoding.t path;
bounded_path_encoding : (option Z) ->
unit -> Tezos_data_encoding.Data_encoding.t path;
compute_path : (list elt) -> Z -> path;
check_path : path -> elt -> t * Z;
}.
Arguments signature : clear implicits.
End MERKLE_TREE.
Module SIGNATURE.
Record signature {Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t Public_key_hash_Error_table_t
Public_key_hash_WeakRingTable_t Public_key_t Secret_key_t t watermark :
Type} := {
Public_key_hash : signature;
Public_key : signature;
Secret_key : signature;
t := t;
pp : Stdlib.Format.formatter -> t -> unit;
include;
include;
include;
zero : t;
watermark := watermark;
sign : (option watermark) -> Secret_key.t -> Stdlib.Bytes.t -> t;
check : (option watermark) -> Public_key.t -> t -> Stdlib.Bytes.t -> bool;
generate_key : (option Bigstring.t) ->
unit -> Public_key_hash.t * Public_key.t * Secret_key.t;
deterministic_nonce : Secret_key.t -> Stdlib.Bytes.t -> Bigstring.t;
deterministic_nonce_hash : Secret_key.t -> Stdlib.Bytes.t -> Stdlib.Bytes.t;
}.
Arguments signature : clear implicits.
End SIGNATURE.
src/lib_crypto/secp256k1.ml 90 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Public_key_hash = struct
include Blake2B.Make
(Base58)
(struct
let name = "Secp256k1.Public_key_hash"
let title = "A Secp256k1 public key hash"
let b58check_prefix = Base58.Prefix.secp256k1_public_key_hash
let size = Some 20
end)
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
end
let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz2" 36
open Libsecp256k1.External
let context =
let ctx = Context.create () in
match Context.randomize ctx (Hacl.Rand.gen 32) with
| false ->
failwith "Secp256k1 context randomization failed. Aborting."
| true ->
ctx
module Public_key = struct
type t = Key.public Key.t
let name = "Secp256k1.Public_key"
let title = "A Secp256k1 public key"
let to_bytes pk = Bigstring.to_bytes (Key.to_bytes context pk)
let of_bytes_opt s =
try Some (Key.read_pk_exn context (Bigstring.of_bytes s)) with _ -> None
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let size = Key.compressed_pk_bytes
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_public_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "sppk" 55
let hash v = Public_key_hash.hash_bytes [to_bytes v]
include Compare.Make (struct
type nonrec t = t
let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
module Secret_key = struct
type t = Key.secret Key.t
let name = "Secp256k1.Secret_key"
let title = "A Secp256k1 secret key"
let size = Key.secret_bytes
let of_bytes_opt s =
match Key.read_sk context (Bigstring.of_bytes s) with
| Ok x ->
Some x
| _ ->
None
let to_bigstring = Key.to_bytes context
let to_bytes x = Bigstring.to_bytes (to_bigstring x)
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let to_public_key key = Key.neuterize_exn context key
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_secret_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "spsk" 54
include Compare.Make (struct
type nonrec t = t
let compare a b = Bigstring.compare (Key.buffer a) (Key.buffer b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
type t = Sign.plain Sign.t
type watermark = Bytes.t
let name = "Secp256k1"
let title = "A Secp256k1 signature"
let size = Sign.plain_bytes
let of_bytes_opt s =
match Sign.read context (Bigstring.of_bytes s) with
| Ok s ->
Some s
| Error _ ->
None
let to_bytes t = Bigstring.to_bytes (Sign.to_bytes ~der:false context t)
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_signature
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "spsig1" 99
include Compare.Make (struct
type nonrec t = t
let compare a b = Bigstring.compare (Sign.buffer a) (Sign.buffer b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
let zero = of_bytes_exn (Bytes.make size '\000')
let sign ?watermark sk msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
Sign.sign_exn context ~sk (Bigstring.of_bytes msg)
let check ?watermark public_key signature msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
Sign.verify_exn
context
~pk:public_key
~msg:(Bigstring.of_bytes msg)
~signature
let generate_key ?(seed = Hacl.Rand.gen 32) () =
let sk = Key.read_sk_exn context seed in
let pk = Key.neuterize_exn context sk in
let pkh = Public_key.hash pk in
(pkh, pk, sk)
let deterministic_nonce sk msg =
let msg = Bigstring.of_bytes msg in
let key = Secret_key.to_bigstring sk in
Hacl.Hash.SHA256.HMAC.digest ~key ~msg
let deterministic_nonce_hash sk msg =
let nonce = deterministic_nonce sk msg in
Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce])
src/lib_crypto/secp256k1.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Public_key_hash.
(* ❌ Structure item `include` not handled. *)
include
Module Logging.
Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
End Logging.
End Public_key_hash.
Import Libsecp256k1.External.
Definition context : Libsecp256k1.External.Context.t :=
let ctx := Context.create None None tt in
match Context.randomize ctx (Hacl.Rand.gen 32) with
| false =>
OCaml.Stdlib.failwith
"Secp256k1 context randomization failed. Aborting." % string
| true => ctx
end.
Module Public_key.
Definition t := Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public.
Definition name : string := "Secp256k1.Public_key" % string.
Definition title : string := "A Secp256k1 public key" % string.
Definition to_bytes {A : Type} (pk : Libsecp256k1.External.Key.t A)
: Stdlib.Bytes.t := Bigstring.to_bytes (Key.to_bytes None context pk).
Definition of_bytes_opt (s : Stdlib.Bytes.t)
: option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
(* ❌ Try-with are not handled *)
try (Some (Key.read_pk_exn context (Bigstring.of_bytes s))).
Definition to_string {A : Type} (s : Libsecp256k1.External.Key.t A)
: string := Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string)
: option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition size : Z := Key.compressed_pk_bytes.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding
: Tezos_crypto.Base58.encoding
(Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
Base58.register_encoding Base58.Prefix.secp256k1_public_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
Definition hash {A : Type} (v : Libsecp256k1.External.Key.t A)
: Public_key_hash.t :=
Public_key_hash.hash_bytes None (cons (to_bytes v) []).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.
Module Secret_key.
Definition t := Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret.
Definition name : string := "Secp256k1.Secret_key" % string.
Definition title : string := "A Secp256k1 secret key" % string.
Definition size : Z := Key.secret_bytes.
Definition of_bytes_opt (s : Stdlib.Bytes.t)
: option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
match Key.read_sk context (Bigstring.of_bytes s) with
| Stdlib.Ok x => Some x
| _ => None
end.
Definition to_bigstring
: (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) ->
Bigstring.t := Key.to_bytes None context.
Definition to_bytes
(x : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
: Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring x).
Definition to_string
(s : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
: string := Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string)
: option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition to_public_key {A : Type} (key : Libsecp256k1.External.Key.t A)
: Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public :=
Key.neuterize_exn context key.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding
: Tezos_crypto.Base58.encoding
(Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
Base58.register_encoding Base58.Prefix.secp256k1_secret_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.
Definition t := Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain.
Definition watermark := Stdlib.Bytes.t.
Definition name : string := "Secp256k1" % string.
Definition title : string := "A Secp256k1 signature" % string.
Definition size : Z := Sign.plain_bytes.
Definition of_bytes_opt (s : Stdlib.Bytes.t)
: option (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
match Sign.read context (Bigstring.of_bytes s) with
| Stdlib.Ok s => Some s
| Stdlib.Error _ => None
end.
Definition to_bytes {A : Type} (t : Libsecp256k1.External.Sign.t A)
: Stdlib.Bytes.t := Bigstring.to_bytes (Sign.to_bytes (Some false) context t).
Definition to_string {A : Type} (s : Libsecp256k1.External.Sign.t A) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string)
: option (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding
: Tezos_crypto.Base58.encoding
(Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
Base58.register_encoding Base58.Prefix.secp256k1_signature size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
Definition zero : t := of_bytes_exn (Stdlib.Bytes.make size "000" % char).
Definition sign
(watermark : option Stdlib.Bytes.t)
(sk : Libsecp256k1__External.Key.t Libsecp256k1__External.Key.secret)
(msg : Stdlib.Bytes.t)
: Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
Sign.sign_exn context sk (Bigstring.of_bytes msg).
Definition check {A : Type}
(watermark : option Stdlib.Bytes.t)
(public_key : Libsecp256k1__External.Key.t Libsecp256k1__External.Key.public)
(signature : Libsecp256k1.External.Sign.t A) (msg : Stdlib.Bytes.t) : bool :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
Sign.verify_exn context public_key (Bigstring.of_bytes msg) signature.
Definition generate_key (op_staroptstar : option Bigstring.t)
: unit ->
Public_key_hash.t *
(Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) *
(Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
let seed :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Hacl.Rand.gen 32
end in
fun function_parameter =>
let 'tt := function_parameter in
let sk := Key.read_sk_exn context seed in
let pk := Key.neuterize_exn context sk in
let pkh := Public_key.hash pk in
(pkh, pk, sk).
Definition deterministic_nonce
(sk : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
(msg : Stdlib.Bytes.t) : Bigstring.t :=
let msg := Bigstring.of_bytes msg in
let key := Secret_key.to_bigstring sk in
Hacl.Hash.SHA256.HMAC.digest key msg.
Definition deterministic_nonce_hash
(sk : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
(msg : Stdlib.Bytes.t) : Stdlib.Bytes.t :=
let nonce := deterministic_nonce sk msg in
Blake2B.to_bytes
(Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])).
src/lib_crypto/secp256k1_group.ml 91 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Sp = Libsecp256k1.Internal
module type SCALAR_SIG = sig
type t
include S.B58_DATA with type t := t
include S.ENCODER with type t := t
val zero : t
val one : t
val of_Z : Z.t -> t
val to_Z : t -> Z.t
val of_int : int -> t
val add : t -> t -> t
val mul : t -> t -> t
val negate : t -> t
val sub : t -> t -> t
val of_bits_exn : string -> t
val to_bits : t -> string
val inverse : t -> t option
val pow : t -> Z.t -> t
val equal : t -> t -> bool
end
module Group : sig
val order : Z.t
module Scalar : SCALAR_SIG
type t
include S.B58_DATA with type t := t
include S.ENCODER with type t := t
val e : t
val g : t
val h : t
val of_coordinates : x:Z.t -> y:Z.t -> t
val of_bits_exn : string -> t
val to_bits : t -> string
val mul : Scalar.t -> t -> t
val ( + ) : t -> t -> t
val ( - ) : t -> t -> t
val ( = ) : t -> t -> bool
end = struct
let order =
Z.of_string_base
16
"FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141"
let string_rev s =
let len = String.length s in
String.init len (fun i -> s.[len - 1 - i])
let b32_of_Z z =
let cs = Cstruct.create 32 in
let bits = Z.to_bits z in
let length = min 32 (String.length bits) in
let bits = String.sub bits 0 length in
let bits = string_rev bits in
Cstruct.blit_from_string bits 0 cs (32 - length) length ;
cs
let z_of_b32 b = b |> Cstruct.to_string |> string_rev |> Z.of_bits
module Scalar : SCALAR_SIG with type t = Sp.Scalar.t = struct
type t = Sp.Scalar.t
let zero = Sp.Scalar.zero ()
let one = Sp.Scalar.one ()
let equal x y = Sp.Scalar.equal x y
let of_Z z =
let z = Z.erem z order in
let r = Sp.Scalar.const () in
let cs = b32_of_Z z in
let _ = Sp.Scalar.set_b32 r cs in
r
let to_Z s =
let cs = Cstruct.create 32 in
Sp.Scalar.get_b32 cs s ; cs |> z_of_b32
let of_int i = i |> Z.of_int |> of_Z
let pow t n = Z.powm (to_Z t) n order |> of_Z
let add x y =
let r = Sp.Scalar.const () in
let _ = Sp.Scalar.add r x y in
r
let mul x y =
let r = Sp.Scalar.const () in
Sp.Scalar.mul r x y ; r
let negate x =
let r = Sp.Scalar.const () in
Sp.Scalar.negate r x ; r
let sub x y = add x (negate y)
let of_bits_exn bits =
let r = Sp.Scalar.const () in
(* trim to 32 bytes *)
let cs = Cstruct.create 32 in
Cstruct.blit_from_string bits 0 cs 0 (min (String.length bits) 32) ;
(* ignore overflow condition, it's always 0 based on the c-code *)
let _ = Sp.Scalar.set_b32 r cs in
r
(* TODO, check that we are less than the order *)
let to_bits x =
let c = Cstruct.create 32 in
Sp.Scalar.get_b32 c x ; Cstruct.to_string c
let inverse x =
if x = zero then None
else
let r = Sp.Scalar.const () in
Sp.Scalar.inverse r x ; Some r
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_scalar
~length:32
~to_raw:to_bits
~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
~wrap:(fun x -> Data x)
let title = "Secp256k1_group.Scalar"
let name = "Anscalar for the secp256k1 group"
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
end)
end
type t = Sp.Group.Jacobian.t
(* type ge = Sp.Group.ge *)
let field_of_Z z =
let fe = Sp.Field.const () in
let cs = b32_of_Z z in
let _ = Sp.Field.set_b32 fe cs in
fe
let group_of_jacobian j =
let r = Sp.Group.of_fields () in
Sp.Group.Jacobian.get_ge r j ;
r
let jacobian_of_group g =
let j = Sp.Group.Jacobian.of_fields () in
Sp.Group.Jacobian.set_ge j g ;
j
let of_coordinates ~x ~y =
Sp.Group.of_fields ~x:(field_of_Z x) ~y:(field_of_Z y) ()
|> jacobian_of_group
let e = Sp.Group.Jacobian.of_fields ~infinity:true ()
let g =
let gx =
Z.of_string
"55066263022277343669578718895168534326250603453777594175500187360389116729240"
and gy =
Z.of_string
"32670510020758816978083085130507043184471273380659243275938904335757337482424"
in
of_coordinates ~x:gx ~y:gy
(* To obtain the second generator, take the sha256 hash of the decimal representation of g1_y
python -c "import hashlib;print int(hashlib.sha256('32670510020758816978083085130507043184471273380659243275938904335757337482424').hexdigest(),16)"
*)
let h =
let hx =
Z.of_string
"54850469061264194188802857211425616972714231399857248865148107587305936171824"
and hy =
Z.of_string
"6558914719042992724977242403721980463337660510165027616783569279181206179101"
in
of_coordinates ~x:hx ~y:hy
let ( + ) x y =
let r = Sp.Group.Jacobian.of_fields () in
Sp.Group.Jacobian.add_var r x y ;
r
let ( - ) x y =
let neg_y = Sp.Group.Jacobian.of_fields () in
Sp.Group.Jacobian.neg neg_y y ;
x + neg_y
let ( = ) x y = Sp.Group.Jacobian.is_infinity (x - y)
let mul s g =
let r = Sp.Group.Jacobian.of_fields () in
Sp.Group.Jacobian.mul r (group_of_jacobian g) s ;
r
let to_bits j =
let x = group_of_jacobian j and buf = Cstruct.create 33 in
let cs = Sp.Group.to_pubkey ~compress:true buf x in
Cstruct.to_string cs
let of_bits_exn bits =
let buf = Cstruct.of_string bits and x = Sp.Group.of_fields () in
Sp.Group.from_pubkey x buf ; x |> jacobian_of_group
module Encoding = struct
type Base58.data += Data of t
let title = "Secp256k1_group.Group"
let name = "An element of secp256k1"
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_element
~length:33
~to_raw:to_bits
~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
~wrap:(fun x -> Data x)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
end)
end
include Encoding
end
src/lib_crypto/secp256k1_group.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module SCALAR_SIG.
Record signature {t : Type} := {
t := t;
include;
include;
zero : t;
one : t;
of_Z : Z.t -> t;
to_Z : t -> Z.t;
of_int : Z -> t;
add : t -> t -> t;
mul : t -> t -> t;
negate : t -> t;
sub : t -> t -> t;
of_bits_exn : string -> t;
to_bits : t -> string;
inverse : t -> option t;
pow : t -> Z.t -> t;
equal : t -> t -> bool;
}.
Arguments signature : clear implicits.
End SCALAR_SIG.
Module Group.
Definition order : Z.t :=
Z.of_string_base 16
"FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141" %
string.
Definition string_rev (s : string) : string :=
let len := OCaml.String.length s in
Stdlib.String.init len
(fun i => Stdlib.String.get s (Z.sub (Z.sub len 1) i)).
Definition b32_of_Z (z : Z.t) : Cstruct.t :=
let cs := Cstruct.create 32 in
let bits := Z.to_bits z in
let length := OCaml.Stdlib.min 32 (OCaml.String.length bits) in
let bits := Stdlib.String.sub bits 0 length in
let bits := string_rev bits in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Cstruct.blit_from_string bits 0 cs (Z.sub 32 length) length in
cs.
Definition z_of_b32 (b : Cstruct.t) : Z.t :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply b Cstruct.to_string) string_rev) Z.of_bits.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition t := Sp.Group.Jacobian.t.
Definition field_of_Z (z : Z.t) : Sp.Field.t :=
let fe := Sp.Field.const None None None None None None None None tt in
let cs := b32_of_Z z in
let '_ := Sp.Field.set_b32 fe cs in
fe.
Definition group_of_jacobian (j : Sp.Group.Jacobian.t) : Sp.Group.t :=
let r := Sp.Group.of_fields None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.get_ge r j in
r.
Definition jacobian_of_group (g : Libsecp256k1__Internal.Group.ge)
: Sp.Group.Jacobian.t :=
let j := Sp.Group.Jacobian.of_fields None None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.set_ge j g in
j.
Definition of_coordinates (x : Z.t) (y : Z.t) : Sp.Group.Jacobian.t :=
OCaml.Stdlib.reverse_apply
(Sp.Group.of_fields (Some (field_of_Z x)) (Some (field_of_Z y)) None tt)
jacobian_of_group.
Definition e : Sp.Group.Jacobian.t :=
Sp.Group.Jacobian.of_fields None None None (Some true) tt.
Definition g : Sp.Group.Jacobian.t :=
let gx : Z.t :=
Z.of_string
"55066263022277343669578718895168534326250603453777594175500187360389116729240"
% string
with gy : Z.t :=
Z.of_string
"32670510020758816978083085130507043184471273380659243275938904335757337482424"
% string in
of_coordinates gx gy.
Definition h : Sp.Group.Jacobian.t :=
let hx : Z.t :=
Z.of_string
"54850469061264194188802857211425616972714231399857248865148107587305936171824"
% string
with hy : Z.t :=
Z.of_string
"6558914719042992724977242403721980463337660510165027616783569279181206179101"
% string in
of_coordinates hx hy.
Definition op_plus (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t)
: Sp.Group.Jacobian.t :=
let r := Sp.Group.Jacobian.of_fields None None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.add_var None r x y in
r.
Definition op_minus (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t)
: Sp.Group.Jacobian.t :=
let neg_y := Sp.Group.Jacobian.of_fields None None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.neg neg_y y in
op_plus x neg_y.
Definition op_eq (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t) : bool :=
Sp.Group.Jacobian.is_infinity (op_minus x y).
Definition mul (s : Libsecp256k1__Internal.Scalar.t) (g : Sp.Group.Jacobian.t)
: Sp.Group.Jacobian.t :=
let r := Sp.Group.Jacobian.of_fields None None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.mul r (group_of_jacobian g) s in
r.
Definition to_bits (j : Sp.Group.Jacobian.t) : string :=
let x : Sp.Group.t :=
group_of_jacobian j
with buf : Cstruct.t :=
Cstruct.create 33 in
let cs := Sp.Group.to_pubkey (Some true) buf x in
Cstruct.to_string cs.
Definition of_bits_exn (bits : string) : Sp.Group.Jacobian.t :=
let buf : Cstruct.t :=
Cstruct.of_string None None None bits
with x : Sp.Group.t :=
Sp.Group.of_fields None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.from_pubkey x buf in
OCaml.Stdlib.reverse_apply x jacobian_of_group.
Module Encoding.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition title : string := "Secp256k1_group.Group" % string.
Definition name : string := "An element of secp256k1" % string.
Definition b58check_encoding
: Tezos_crypto.Base58.encoding Sp.Group.Jacobian.t :=
Base58.register_encoding Base58.Prefix.secp256k1_element 33 to_bits
(fun s =>
(* ❌ Try-with are not handled *)
try (Some (of_bits_exn s))) (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Encoding.
(* ❌ Structure item `include` not handled. *)
include
End Group.
src/lib_crypto/test/roundtrips.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let test_rt_opt name testable enc dec input =
try
let roundtripped = dec (enc input) in
Alcotest.check (Alcotest.option testable) name (Some input) roundtripped
with exc ->
Alcotest.failf
"%s failed for %a: exception whilst decoding: %s"
name
(Alcotest.pp testable)
input
(Printexc.to_string exc)
let test_decode_opt_safe name testable dec encoded =
match dec encoded with
| Some _ | None ->
()
| exception exc ->
Alcotest.failf
"%s failed for %a: exception whilst decoding: %s"
name
(Alcotest.pp testable)
encoded
(Printexc.to_string exc)
let test_decode_opt_fail name testable dec encoded =
try
let decoded = dec encoded in
Alcotest.check (Alcotest.option testable) name None decoded
with exc ->
Alcotest.failf
"%s failed: exception whilst decoding: %s"
name
(Printexc.to_string exc)
src/lib_crypto/test/roundtrips.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_rt_opt {A B C D E F : Type}
(name : A) (testable : B) (enc : C -> D) (dec : D -> E) (input : C) : F :=
(* ❌ Try-with are not handled *)
try
(let roundtripped := dec (enc input) in
op_startypeminuserrorstar (op_startypeminuserrorstar testable) name
(Some input) roundtripped).
Definition test_decode_opt_safe {A B C D : Type}
(name : A) (testable : B) (dec : C -> option D) (encoded : C) : unit :=
let 'Some _ | None := dec encoded in
tt.
Definition test_decode_opt_fail {A B C D E : Type}
(name : A) (testable : B) (dec : C -> D) (encoded : C) : E :=
(* ❌ Try-with are not handled *)
try
(let decoded := dec encoded in
op_startypeminuserrorstar (op_startypeminuserrorstar testable) name None
decoded).
src/lib_crypto/test/test_base58.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let test_roundtrip_safe input =
Roundtrips.test_rt_opt
"safe base58"
Alcotest.string
Base58.safe_encode
Base58.safe_decode
input
let test_roundtrip_raw input =
Roundtrips.test_rt_opt
"raw base58"
Alcotest.string
Base58.raw_encode
Base58.raw_decode
input
let inputs =
[ "abc";
string_of_int max_int;
"0";
"00";
"000";
"0000";
"0000000000000000";
String.make 64 '0';
"1";
"11";
"111";
"1111";
String.make 2048 '0';
"2";
"22";
"5";
"Z";
String.make 2048 'Z';
"z";
"zz";
"zzzzzzzz";
String.make 2048 'z';
(*loads of ascii characters: codes between 32 and 126 *)
String.init 1000 (fun i -> Char.chr (32 + (i mod (126 - 32))));
"" ]
let test_roundtrip_safes () = List.iter test_roundtrip_safe inputs
let test_roundtrip_raws () = List.iter test_roundtrip_raw inputs
let test_safety input =
Roundtrips.test_decode_opt_safe
"safe base58"
Alcotest.string
Base58.safe_decode
input
let test_safetys () = List.iter test_safety inputs
let tests =
[ ("safe decoding", `Quick, test_safetys);
("safe encoding/decoding", `Quick, test_roundtrip_safes);
("raw encoding/decoding", `Quick, test_roundtrip_raws) ]
let () = Alcotest.run "tezos-crypto" [("base58", tests)]
src/lib_crypto/test/test_base58.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_roundtrip_safe {A B : Type} (input : A) : B :=
op_startypeminuserrorstar "safe base58" % string op_startypeminuserrorstar
Base58.safe_encode Base58.safe_decode input.
Definition test_roundtrip_raw {A B : Type} (input : A) : B :=
op_startypeminuserrorstar "raw base58" % string op_startypeminuserrorstar
Base58.raw_encode Base58.raw_decode input.
Definition inputs : list string :=
cons "abc" % string
(cons (OCaml.Stdlib.string_of_int Stdlib.max_int)
(cons "0" % string
(cons "00" % string
(cons "000" % string
(cons "0000" % string
(cons "0000000000000000" % string
(cons (Stdlib.String.make 64 "0" % char)
(cons "1" % string
(cons "11" % string
(cons "111" % string
(cons "1111" % string
(cons (Stdlib.String.make 2048 "0" % char)
(cons "2" % string
(cons "22" % string
(cons "5" % string
(cons "Z" % string
(cons (Stdlib.String.make 2048 "Z" % char)
(cons "z" % string
(cons "zz" % string
(cons "zzzzzzzz" % string
(cons
(Stdlib.String.make 2048
"z" % char)
(cons
(Stdlib.String.init 1000
(fun i =>
Char.chr
(Z.add 32
(Z.modulo i
(Z.sub 126 32)))))
(cons "" % string []))))))))))))))))))))))).
Definition test_roundtrip_safes (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_roundtrip_safe inputs.
Definition test_roundtrip_raws (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_roundtrip_raw inputs.
Definition test_safety {A B : Type} (input : A) : B :=
op_startypeminuserrorstar "safe base58" % string op_startypeminuserrorstar
Base58.safe_decode input.
Definition test_safetys (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_safety inputs.
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("safe decoding" % string,
(* ❌ Variants not supported *)
variant, test_safetys)
(cons
("safe encoding/decoding" % string,
(* ❌ Variants not supported *)
variant, test_roundtrip_safes)
(cons
("raw encoding/decoding" % string,
(* ❌ Variants not supported *)
variant, test_roundtrip_raws) [])).
src/lib_crypto/test/test_blake2b.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let test_hashed_roundtrip name enc dec input =
(* this wrapper to start with hashing *)
Roundtrips.test_rt_opt
name
(Alcotest.testable
(fun fmt (input, _) -> Format.fprintf fmt "%s" input)
(fun (_, hashed) (_, decoded) -> hashed = decoded))
(fun (_, hashed) -> enc hashed)
(fun encoded ->
match dec encoded with
| None ->
None
| Some decoded ->
Some (input, decoded))
(input, Blake2B.hash_string [input])
let test_roundtrip_hex input =
test_hashed_roundtrip "Hex" Blake2B.to_hex Blake2B.of_hex_opt input
let test_roundtrip_string input =
test_hashed_roundtrip "String" Blake2B.to_string Blake2B.of_string_opt input
let inputs =
[ "abc";
string_of_int max_int;
"0";
"00";
String.make 64 '0';
(*loads of ascii characters: codes between 32 and 126 *)
String.init 1000 (fun i -> Char.chr (32 + (i mod (126 - 32))));
"" ]
let test_roundtrip_hexs () = List.iter test_roundtrip_hex inputs
let test_roundtrip_strings () = List.iter test_roundtrip_string inputs
let tests =
[ ("hash hex/dehex", `Quick, test_roundtrip_hexs);
("hash print/parse", `Quick, test_roundtrip_strings) ]
let () = Alcotest.run "tezos-crypto" [("blake2b", tests)]
src/lib_crypto/test/test_blake2b.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_hashed_roundtrip {A B C D E F : Type}
(name : A) (enc : B -> C) (dec : D -> option E) (input : string) : F :=
op_startypeminuserrorstar name
(op_startypeminuserrorstar
(fun fmt =>
fun function_parameter =>
let '(input, _) := function_parameter in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) input)
(fun function_parameter =>
let '(_, hashed) := function_parameter in
fun function_parameter =>
let '(_, decoded) := function_parameter in
equiv_decb hashed decoded))
(fun function_parameter =>
let '(_, hashed) := function_parameter in
enc hashed)
(fun encoded =>
match dec encoded with
| None => None
| Some decoded => Some (input, decoded)
end) (input, (Blake2B.hash_string None (cons input []))).
Definition test_roundtrip_hex {A : Type} (input : string) : A :=
test_hashed_roundtrip "Hex" % string Blake2B.to_hex Blake2B.of_hex_opt input.
Definition test_roundtrip_string {A : Type} (input : string) : A :=
test_hashed_roundtrip "String" % string Blake2B.to_string
Blake2B.of_string_opt input.
Definition inputs : list string :=
cons "abc" % string
(cons (OCaml.Stdlib.string_of_int Stdlib.max_int)
(cons "0" % string
(cons "00" % string
(cons (Stdlib.String.make 64 "0" % char)
(cons
(Stdlib.String.init 1000
(fun i => Char.chr (Z.add 32 (Z.modulo i (Z.sub 126 32)))))
(cons "" % string [])))))).
Definition test_roundtrip_hexs (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_roundtrip_hex inputs.
Definition test_roundtrip_strings (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_roundtrip_string inputs.
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("hash hex/dehex" % string,
(* ❌ Variants not supported *)
variant, test_roundtrip_hexs)
(cons
("hash print/parse" % string,
(* ❌ Variants not supported *)
variant, test_roundtrip_strings) []).
src/lib_crypto/test/test_crypto_box.ml 21 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let (sk, pk, pkh) = Crypto_box.random_keypair ()
let zero_nonce = Crypto_box.zero_nonce
let chkey = Crypto_box.precompute sk pk
let test_check_pow () =
let target = Crypto_box.make_target 2. in
let pow = Crypto_box.generate_proof_of_work pk target in
Alcotest.(check bool)
"check_pow"
(Crypto_box.check_proof_of_work pk pow target)
true
let test_neutrize sk pk () =
Alcotest.check
(Alcotest.testable Crypto_box.pp_pk Crypto_box.equal)
"neuterize"
(Crypto_box.neuterize sk)
pk
let test_hash pk pkh () =
Alcotest.check
(Alcotest.testable
Crypto_box.Public_key_hash.pp
Crypto_box.Public_key_hash.equal)
"test_hash"
(Crypto_box.hash pk)
pkh
let test_fast_box msg () =
let msglen = Bytes.length msg in
let buf_length = msglen + Crypto_box.zerobytes in
let buf = Bytes.make buf_length '\x00' in
Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
(* encryption / decryption *)
Crypto_box.fast_box_noalloc chkey zero_nonce buf ;
ignore (Crypto_box.fast_box_open_noalloc chkey zero_nonce buf) ;
let res =
Bytes.sub buf Crypto_box.zerobytes (buf_length - Crypto_box.zerobytes)
in
Alcotest.check
Alcotest.(testable (fun fmt x -> Hex.pp fmt (Hex.of_bytes x)) Bytes.equal)
"test_fastbox enc/dec"
res
msg
let tests =
[ ("Neutrize Secret roundtrip", `Quick, test_neutrize sk pk);
("Public Key Hash roundtrip", `Quick, test_hash pk pkh);
("Check PoW", `Slow, test_check_pow);
("Test hacl fastbox", `Quick, test_fast_box (Bytes.of_string "test")) ]
let () = Alcotest.run "tezos-crypto" [("crypto_box", tests)]
src/lib_crypto/test/test_crypto_box.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition zero_nonce : Tezos_crypto.Crypto_box.nonce := Crypto_box.zero_nonce.
Definition chkey : Tezos_crypto.Crypto_box.channel_key :=
Crypto_box.precompute sk pk.
Definition test_check_pow {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
let target :=
Crypto_box.make_target
(* ❌ Float constant 2. is approximated by the integer 2 *)
2 in
let pow := Crypto_box.generate_proof_of_work None pk target in
op_startypeminuserrorstar "check_pow" % string
(Crypto_box.check_proof_of_work pk pow target) true.
Definition test_neutrize {A B : Type}
(sk : Tezos_crypto.Crypto_box.secret_key) (pk : A) (function_parameter : unit)
: B :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar Crypto_box.pp_pk Crypto_box.equal)
"neuterize" % string (Crypto_box.neuterize sk) pk.
Definition test_hash {A B : Type}
(pk : Tezos_crypto.Crypto_box.public_key) (pkh : A)
(function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar Crypto_box.Public_key_hash.pp
Crypto_box.Public_key_hash.equal) "test_hash" % string
(Crypto_box.hash pk) pkh.
Definition test_fast_box {A : Type} (msg : string) (function_parameter : unit)
: A :=
let 'tt := function_parameter in
let msglen := String.length msg in
let buf_length := Z.add msglen Crypto_box.zerobytes in
let buf := Stdlib.Bytes.make buf_length "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.blit msg 0 buf Crypto_box.zerobytes msglen in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Crypto_box.fast_box_noalloc chkey zero_nonce buf in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore (Crypto_box.fast_box_open_noalloc chkey zero_nonce buf)
in
let res :=
String.sub buf Crypto_box.zerobytes (Z.sub buf_length Crypto_box.zerobytes)
in
op_startypeminuserrorstar op_startypeminuserrorstar
"test_fastbox enc/dec" % string res msg.
Definition tests {A : Type} : list (string * variant * (unit -> A)) :=
cons
("Neutrize Secret roundtrip" % string,
(* ❌ Variants not supported *)
variant, (test_neutrize sk pk))
(cons
("Public Key Hash roundtrip" % string,
(* ❌ Variants not supported *)
variant, (test_hash pk pkh))
(cons
("Check PoW" % string,
(* ❌ Variants not supported *)
variant, test_check_pow)
(cons
("Test hacl fastbox" % string,
(* ❌ Variants not supported *)
variant, (test_fast_box (Stdlib.Bytes.of_string "test" % string)))
[]))).
src/lib_crypto/test/test_deterministic_nonce.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let test_hash_matches (module X : S.SIGNATURE) () =
let (_, _, sk) = X.generate_key () in
let data = Bytes.of_string "ce input sa pun eu aici oare?" in
let nonce = X.deterministic_nonce sk data in
let nonce_hash = X.deterministic_nonce_hash sk data in
let hashed_nonce = Blake2B.hash_bytes [Bigstring.to_bytes nonce] in
if nonce_hash <> Blake2B.to_bytes hashed_nonce then
Alcotest.failf
"the hash of deterministic_nonce is NOT deterministic_nonce_hash"
let ed25519 = (module Ed25519 : S.SIGNATURE)
let p256 = (module P256 : S.SIGNATURE)
let secp256k1 = (module Secp256k1 : S.SIGNATURE)
let tests =
[ ("hash_matches_ed25519", `Quick, test_hash_matches ed25519);
("hash_matches_p256", `Quick, test_hash_matches p256);
("hash_matches_secp256k1", `Quick, test_hash_matches secp256k1) ]
let () = Alcotest.run "tezos-crypto" [("deterministic_nonce", tests)]
src/lib_crypto/test/test_deterministic_nonce.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_hash_matches
(X :
{'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
Public_key_hash_Table_t, Public_key_hash_Error_table_t,
Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark)
: _ &
Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t
Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t
Public_key_t Secret_key_t t watermark}) : unit -> unit :=
let X := projT2 X in
fun function_parameter =>
let 'tt := function_parameter in
let '(_, _, sk) := X.(Tezos_crypto__S.SIGNATURE.generate_key) None tt in
let data := Stdlib.Bytes.of_string "ce input sa pun eu aici oare?" % string
in
let nonce := X.(Tezos_crypto__S.SIGNATURE.deterministic_nonce) sk data in
let nonce_hash :=
X.(Tezos_crypto__S.SIGNATURE.deterministic_nonce_hash) sk data in
let hashed_nonce :=
Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) []) in
if nequiv_decb nonce_hash (Blake2B.to_bytes hashed_nonce) then
op_startypeminuserrorstar
"the hash of deterministic_nonce is NOT deterministic_nonce_hash" %
string
else
tt.
Definition ed25519
: {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
Public_key_hash_Table_t, Public_key_hash_Error_table_t,
Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
_ &
Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t
Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
Secret_key_t t watermark} := Ed25519.
Definition p256
: {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
Public_key_hash_Table_t, Public_key_hash_Error_table_t,
Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
_ &
Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t
Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
Secret_key_t t watermark} := P256.
Definition secp256k1
: {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
Public_key_hash_Table_t, Public_key_hash_Error_table_t,
Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
_ &
Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t
Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
Secret_key_t t watermark} := Secp256k1.
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("hash_matches_ed25519" % string,
(* ❌ Variants not supported *)
variant, (test_hash_matches ed25519))
(cons
("hash_matches_p256" % string,
(* ❌ Variants not supported *)
variant, (test_hash_matches p256))
(cons
("hash_matches_secp256k1" % string,
(* ❌ Variants not supported *)
variant, (test_hash_matches secp256k1)) [])).
src/lib_crypto/test/test_ed25519.ml 17 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type B58CHECK = sig
type t
val pp : Format.formatter -> t -> unit
include S.B58_DATA with type t := t
end
let test_b58check_roundtrip :
type t. (module B58CHECK with type t = t) -> t -> unit =
fun m input ->
let module M = (val m) in
let testable = Alcotest.testable M.pp ( = ) in
Roundtrips.test_rt_opt
"b58check"
testable
M.to_b58check
M.of_b58check_opt
input
let test_b58check_roundtrips () =
let (pubkey_hash, pubkey, seckey) = Ed25519.generate_key () in
test_b58check_roundtrip (module Ed25519.Public_key_hash) pubkey_hash ;
test_b58check_roundtrip (module Ed25519.Public_key) pubkey ;
test_b58check_roundtrip (module Ed25519.Secret_key) seckey
let test_b58check_invalid input =
Roundtrips.test_decode_opt_fail
"b58check"
(Alcotest.testable Ed25519.Public_key_hash.pp Ed25519.Public_key_hash.( = ))
Ed25519.Public_key_hash.of_b58check_opt
input
let test_b58check_invalids () =
List.iter
test_b58check_invalid
[ "ThisIsGarbageNotACheck";
"\x00";
String.make 1000 '\x00';
String.make 2048 'a';
String.init 2048 (fun _ -> Char.chr (Random.int 256));
"" ]
let tests =
[ ("b58check.roundtrip", `Quick, test_b58check_roundtrips);
("b58check.invalid", `Slow, test_b58check_invalids) ]
let () = Alcotest.run "tezos-crypto" [("ed25519", tests)]
src/lib_crypto/test/test_ed25519.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module B58CHECK.
Record signature {t : Type} := {
t := t;
pp : Stdlib.Format.formatter -> t -> unit;
include;
}.
Arguments signature : clear implicits.
End B58CHECK.
Definition test_b58check_roundtrip {t : Type}
(m : {_ : unit & B58CHECK.signature t}) (input : t) : unit :=
let M := projT2 m in
let testable := op_startypeminuserrorstar M.(B58CHECK.pp) equiv_decb in
op_startypeminuserrorstar "b58check" % string testable
M.(B58CHECK.to_b58check) M.(B58CHECK.of_b58check_opt) input.
Definition test_b58check_roundtrips (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let '(pubkey_hash, pubkey, seckey) := Ed25519.generate_key None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := test_b58check_roundtrip Ed25519.Public_key_hash pubkey_hash in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := test_b58check_roundtrip Ed25519.Public_key pubkey in
test_b58check_roundtrip Ed25519.Secret_key seckey.
Definition test_b58check_invalid {A B : Type} (input : A) : B :=
op_startypeminuserrorstar "b58check" % string
(op_startypeminuserrorstar Ed25519.Public_key_hash.pp
Ed25519.Public_key_hash.op_eq) Ed25519.Public_key_hash.of_b58check_opt
input.
Definition test_b58check_invalids (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_b58check_invalid
(cons "ThisIsGarbageNotACheck" % string
(cons "